diff options
Diffstat (limited to 'lib')
68 files changed, 8633 insertions, 2312 deletions
diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/compile_flags.hrl b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/compile_flags.hrl new file mode 100644 index 0000000000..e5ee44ace1 --- /dev/null +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/compile_flags.hrl @@ -0,0 +1,2 @@ +-define(AT_LEAST_19, 1). +-define(AT_LEAST_17, 1). diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_common.hrl b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_common.hrl new file mode 100644 index 0000000000..c10626c5cc --- /dev/null +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_common.hrl @@ -0,0 +1,55 @@ +%%% Copyright 2010-2013 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2013 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis +%%% @doc Common parts of user and internal header files + + +%%------------------------------------------------------------------------------ +%% Test generation macros +%%------------------------------------------------------------------------------ + +-define(FORALL(X,RawType,Prop), proper:forall(RawType,fun(X) -> Prop end)). +-define(IMPLIES(Pre,Prop), proper:implies(Pre,?DELAY(Prop))). +-define(WHENFAIL(Action,Prop), proper:whenfail(?DELAY(Action),?DELAY(Prop))). +-define(TRAPEXIT(Prop), proper:trapexit(?DELAY(Prop))). +-define(TIMEOUT(Limit,Prop), proper:timeout(Limit,?DELAY(Prop))). +%% TODO: -define(ALWAYS(Tests,Prop), proper:always(Tests,?DELAY(Prop))). +%% TODO: -define(SOMETIMES(Tests,Prop), proper:sometimes(Tests,?DELAY(Prop))). + + +%%------------------------------------------------------------------------------ +%% Generator macros +%%------------------------------------------------------------------------------ + +-define(FORCE(X), (X)()). +-define(DELAY(X), fun() -> X end). +-define(LAZY(X), proper_types:lazy(?DELAY(X))). +-define(SIZED(SizeArg,Gen), proper_types:sized(fun(SizeArg) -> Gen end)). +-define(LET(X,RawType,Gen), proper_types:bind(RawType,fun(X) -> Gen end,false)). +-define(SHRINK(Gen,AltGens), + proper_types:shrinkwith(?DELAY(Gen),?DELAY(AltGens))). +-define(LETSHRINK(Xs,RawType,Gen), + proper_types:bind(RawType,fun(Xs) -> Gen end,true)). +-define(SUCHTHAT(X,RawType,Condition), + proper_types:add_constraint(RawType,fun(X) -> Condition end,true)). +-define(SUCHTHATMAYBE(X,RawType,Condition), + proper_types:add_constraint(RawType,fun(X) -> Condition end,false)). diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_gen.erl b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_gen.erl new file mode 100644 index 0000000000..b64a139e4d --- /dev/null +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_gen.erl @@ -0,0 +1,611 @@ +%%% Copyright 2010-2015 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2015 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis + +%%% @doc Generator subsystem and generators for basic types. +%%% +%%% You can use <a href="#index">these</a> functions to try out the random +%%% instance generation and shrinking subsystems. +%%% +%%% CAUTION: These functions should never be used inside properties. They are +%%% meant for demonstration purposes only. + +-module(proper_gen). +-export([pick/1, pick/2, pick/3, + sample/1, sample/3, sampleshrink/1, sampleshrink/2]). + +-export([safe_generate/1]). +-export([generate/1, normal_gen/1, alt_gens/1, clean_instance/1, + get_ret_type/1]). +-export([integer_gen/3, float_gen/3, atom_gen/1, atom_rev/1, binary_gen/1, + binary_rev/1, binary_len_gen/1, bitstring_gen/1, bitstring_rev/1, + bitstring_len_gen/1, list_gen/2, distlist_gen/3, vector_gen/2, + union_gen/1, weighted_union_gen/1, tuple_gen/1, loose_tuple_gen/2, + loose_tuple_rev/2, exactly_gen/1, fixed_list_gen/1, function_gen/2, + any_gen/1, native_type_gen/2, safe_weighted_union_gen/1, + safe_union_gen/1]). + +-export_type([instance/0, imm_instance/0, sized_generator/0, nosize_generator/0, + generator/0, reverse_gen/0, combine_fun/0, alt_gens/0]). + +-include("proper_internal.hrl"). + +%%----------------------------------------------------------------------------- +%% Types +%%----------------------------------------------------------------------------- + +%% TODO: update imm_instance() when adding more types: be careful when reading +%% anything that returns it +%% @private_type +-type imm_instance() :: proper_types:raw_type() + | instance() + | {'$used', imm_instance(), imm_instance()} + | {'$to_part', imm_instance()}. +-type instance() :: term(). +%% A value produced by the random instance generator. +-type error_reason() :: 'arity_limit' | 'cant_generate' | {'typeserver',term()}. + +%% @private_type +-type sized_generator() :: fun((size()) -> imm_instance()). +%% @private_type +-type typed_sized_generator() :: {'typed', + fun((proper_types:type(),size()) -> + imm_instance())}. +%% @private_type +-type nosize_generator() :: fun(() -> imm_instance()). +%% @private_type +-type typed_nosize_generator() :: {'typed', + fun((proper_types:type()) -> + imm_instance())}. +%% @private_type +-type generator() :: sized_generator() + | typed_sized_generator() + | nosize_generator() + | typed_nosize_generator(). +%% @private_type +-type plain_reverse_gen() :: fun((instance()) -> imm_instance()). +%% @private_type +-type typed_reverse_gen() :: {'typed', + fun((proper_types:type(),instance()) -> + imm_instance())}. +%% @private_type +-type reverse_gen() :: plain_reverse_gen() | typed_reverse_gen(). +%% @private_type +-type combine_fun() :: fun((instance()) -> imm_instance()). +%% @private_type +-type alt_gens() :: fun(() -> [imm_instance()]). +%% @private_type +-type fun_seed() :: {non_neg_integer(),non_neg_integer()}. + + +%%----------------------------------------------------------------------------- +%% Instance generation functions +%%----------------------------------------------------------------------------- + +%% @private +-spec safe_generate(proper_types:raw_type()) -> + {'ok',imm_instance()} | {'error',error_reason()}. +safe_generate(RawType) -> + try generate(RawType) of + ImmInstance -> {ok, ImmInstance} + catch + throw:'$arity_limit' -> {error, arity_limit}; + throw:'$cant_generate' -> {error, cant_generate}; + throw:{'$typeserver',SubReason} -> {error, {typeserver,SubReason}} + end. + +%% @private +-spec generate(proper_types:raw_type()) -> imm_instance(). +generate(RawType) -> + Type = proper_types:cook_outer(RawType), + ok = add_parameters(Type), + Instance = generate(Type, get('$constraint_tries'), none), + ok = remove_parameters(Type), + Instance. + +-spec add_parameters(proper_types:type()) -> 'ok'. +add_parameters(Type) -> + case proper_types:find_prop(parameters, Type) of + {ok, Params} -> + OldParams = erlang:get('$parameters'), + case OldParams of + undefined -> + erlang:put('$parameters', Params); + _ -> + erlang:put('$parameters', Params ++ OldParams) + end, + ok; + _ -> + ok + end. + +-spec remove_parameters(proper_types:type()) -> 'ok'. +remove_parameters(Type) -> + case proper_types:find_prop(parameters, Type) of + {ok, Params} -> + AllParams = erlang:get('$parameters'), + case AllParams of + Params-> + erlang:erase('$parameters'); + _ -> + erlang:put('$parameters', AllParams -- Params) + end, + ok; + _ -> + ok + end. + +-spec generate(proper_types:type(), non_neg_integer(), + 'none' | {'ok',imm_instance()}) -> imm_instance(). +generate(_Type, 0, none) -> + throw('$cant_generate'); +generate(_Type, 0, {ok,Fallback}) -> + Fallback; +generate(Type, TriesLeft, Fallback) -> + ImmInstance = + case proper_types:get_prop(kind, Type) of + constructed -> + PartsType = proper_types:get_prop(parts_type, Type), + Combine = proper_types:get_prop(combine, Type), + ImmParts = generate(PartsType), + Parts = clean_instance(ImmParts), + ImmInstance1 = Combine(Parts), + %% TODO: We can just generate the internal type: if it's not + %% a type, it will turn into an exactly. + ImmInstance2 = + case proper_types:is_raw_type(ImmInstance1) of + true -> generate(ImmInstance1); + false -> ImmInstance1 + end, + {'$used',ImmParts,ImmInstance2}; + _ -> + ImmInstance1 = normal_gen(Type), + case proper_types:is_raw_type(ImmInstance1) of + true -> generate(ImmInstance1); + false -> ImmInstance1 + end + end, + case proper_types:satisfies_all(clean_instance(ImmInstance), Type) of + {_,true} -> ImmInstance; + {true,false} -> generate(Type, TriesLeft - 1, {ok,ImmInstance}); + {false,false} -> generate(Type, TriesLeft - 1, Fallback) + end. + +%% @equiv pick(Type, 10) +-spec pick(Type::proper_types:raw_type()) -> {'ok',instance()} | 'error'. +pick(RawType) -> + pick(RawType, 10). + +%% @equiv pick(Type, Size, os:timestamp()) +-spec pick(Type::proper_types:raw_type(), size()) -> {'ok',instance()} | 'error'. +pick(RawType, Size) -> + pick(RawType, Size, os:timestamp()). + +%% @doc Generates a random instance of `Type', of size `Size' with seed `Seed'. +-spec pick(Type::proper_types:raw_type(), size(), seed()) -> + {'ok',instance()} | 'error'. +pick(RawType, Size, Seed) -> + proper:global_state_init_size_seed(Size, Seed), + case clean_instance(safe_generate(RawType)) of + {ok,Instance} = Result -> + Msg = "WARNING: Some garbage has been left in the process registry " + "and the code server~n" + "to allow for the returned function(s) to run normally.~n" + "Please run proper:global_state_erase() when done.~n", + case contains_fun(Instance) of + true -> io:format(Msg, []); + false -> proper:global_state_erase() + end, + Result; + {error,Reason} -> + proper:report_error(Reason, fun io:format/2), + proper:global_state_erase(), + error + end. + +%% @equiv sample(Type, 10, 20) +-spec sample(Type::proper_types:raw_type()) -> 'ok'. +sample(RawType) -> + sample(RawType, 10, 20). + +%% @doc Generates and prints one random instance of `Type' for each size from +%% `StartSize' up to `EndSize'. +-spec sample(Type::proper_types:raw_type(), size(), size()) -> 'ok'. +sample(RawType, StartSize, EndSize) when StartSize =< EndSize -> + Tests = EndSize - StartSize + 1, + Prop = ?FORALL(X, RawType, begin io:format("~p~n",[X]), true end), + Opts = [quiet,{start_size,StartSize},{max_size,EndSize},{numtests,Tests}], + _ = proper:quickcheck(Prop, Opts), + ok. + +%% @equiv sampleshrink(Type, 10) +-spec sampleshrink(Type::proper_types:raw_type()) -> 'ok'. +sampleshrink(RawType) -> + sampleshrink(RawType, 10). + +%% @doc Generates a random instance of `Type', of size `Size', then shrinks it +%% as far as it goes. The value produced on each step of the shrinking process +%% is printed on the screen. +-spec sampleshrink(Type::proper_types:raw_type(), size()) -> 'ok'. +sampleshrink(RawType, Size) -> + proper:global_state_init_size(Size), + Type = proper_types:cook_outer(RawType), + case safe_generate(Type) of + {ok,ImmInstance} -> + Shrunk = keep_shrinking(ImmInstance, [], Type), + PrintInst = fun(I) -> io:format("~p~n",[clean_instance(I)]) end, + lists:foreach(PrintInst, Shrunk); + {error,Reason} -> + proper:report_error(Reason, fun io:format/2) + end, + proper:global_state_erase(), + ok. + +-spec keep_shrinking(imm_instance(), [imm_instance()], proper_types:type()) -> + [imm_instance(),...]. +keep_shrinking(ImmInstance, Acc, Type) -> + keep_shrinking(ImmInstance, Acc, Type, init). + +keep_shrinking(ImmInstance, Acc, Type, State) -> + case proper_shrink:shrink(ImmInstance, Type, State) of + {[], done} -> %% no more shrinkers + lists:reverse([ImmInstance|Acc]); + {[], NewState} -> + %% try next shrinker + keep_shrinking(ImmInstance, Acc, Type, NewState); + {[Shrunk|_Rest], _NewState} -> + Acc2 = [ImmInstance|Acc], + case lists:member(Shrunk, Acc2) of + true -> + %% Avoid infinite loops + lists:reverse(Acc2); + false -> + keep_shrinking(Shrunk, Acc2, Type) + end + end. + +-spec contains_fun(term()) -> boolean(). +contains_fun(List) when is_list(List) -> + proper_arith:safe_any(fun contains_fun/1, List); +contains_fun(Tuple) when is_tuple(Tuple) -> + contains_fun(tuple_to_list(Tuple)); +contains_fun(Fun) when is_function(Fun) -> + true; +contains_fun(_Term) -> + false. + + +%%----------------------------------------------------------------------------- +%% Utility functions +%%----------------------------------------------------------------------------- + +%% @private +-spec normal_gen(proper_types:type()) -> imm_instance(). +normal_gen(Type) -> + case proper_types:get_prop(generator, Type) of + {typed, Gen} -> + if + is_function(Gen, 1) -> Gen(Type); + is_function(Gen, 2) -> Gen(Type, proper:get_size(Type)) + end; + Gen -> + if + is_function(Gen, 0) -> Gen(); + is_function(Gen, 1) -> Gen(proper:get_size(Type)) + end + end. + +%% @private +-spec alt_gens(proper_types:type()) -> [imm_instance()]. +alt_gens(Type) -> + case proper_types:find_prop(alt_gens, Type) of + {ok, AltGens} -> ?FORCE(AltGens); + error -> [] + end. + +%% @private +-spec clean_instance(imm_instance()) -> instance(). +clean_instance({'$used',_ImmParts,ImmInstance}) -> + clean_instance(ImmInstance); +clean_instance({'$to_part',ImmInstance}) -> + clean_instance(ImmInstance); +clean_instance(ImmInstance) -> + if + is_list(ImmInstance) -> + %% CAUTION: this must handle improper lists + proper_arith:safe_map(fun clean_instance/1, ImmInstance); + is_tuple(ImmInstance) -> + proper_arith:tuple_map(fun clean_instance/1, ImmInstance); + true -> + ImmInstance + end. + + +%%----------------------------------------------------------------------------- +%% Basic type generators +%%----------------------------------------------------------------------------- + +%% @private +-spec integer_gen(size(), proper_types:extint(), proper_types:extint()) -> + integer(). +integer_gen(Size, inf, inf) -> + proper_arith:rand_int(Size); +integer_gen(Size, inf, High) -> + High - proper_arith:rand_non_neg_int(Size); +integer_gen(Size, Low, inf) -> + Low + proper_arith:rand_non_neg_int(Size); +integer_gen(Size, Low, High) -> + proper_arith:smart_rand_int(Size, Low, High). + +%% @private +-spec float_gen(size(), proper_types:extnum(), proper_types:extnum()) -> + float(). +float_gen(Size, inf, inf) -> + proper_arith:rand_float(Size); +float_gen(Size, inf, High) -> + High - proper_arith:rand_non_neg_float(Size); +float_gen(Size, Low, inf) -> + Low + proper_arith:rand_non_neg_float(Size); +float_gen(_Size, Low, High) -> + proper_arith:rand_float(Low, High). + +%% @private +-spec atom_gen(size()) -> proper_types:type(). +%% We make sure we never clash with internal atoms by checking that the first +%% character is not '$'. +atom_gen(Size) -> + ?LET(Str, + ?SUCHTHAT(X, + proper_types:resize(Size, + proper_types:list(proper_types:byte())), + X =:= [] orelse hd(X) =/= $$), + list_to_atom(Str)). + +%% @private +-spec atom_rev(atom()) -> imm_instance(). +atom_rev(Atom) -> + {'$used', atom_to_list(Atom), Atom}. + +%% @private +-spec binary_gen(size()) -> proper_types:type(). +binary_gen(Size) -> + ?LET(Bytes, + proper_types:resize(Size, + proper_types:list(proper_types:byte())), + list_to_binary(Bytes)). + +%% @private +-spec binary_rev(binary()) -> imm_instance(). +binary_rev(Binary) -> + {'$used', binary_to_list(Binary), Binary}. + +%% @private +-spec binary_len_gen(length()) -> proper_types:type(). +binary_len_gen(Len) -> + ?LET(Bytes, + proper_types:vector(Len, proper_types:byte()), + list_to_binary(Bytes)). + +%% @private +-spec bitstring_gen(size()) -> proper_types:type(). +bitstring_gen(Size) -> + ?LET({BytesHead, NumBits, TailByte}, + {proper_types:resize(Size,proper_types:binary()), + proper_types:range(0,7), proper_types:range(0,127)}, + <<BytesHead/binary, TailByte:NumBits>>). + +%% @private +-spec bitstring_rev(bitstring()) -> imm_instance(). +bitstring_rev(BitString) -> + List = bitstring_to_list(BitString), + {BytesList, BitsTail} = lists:splitwith(fun erlang:is_integer/1, List), + {NumBits, TailByte} = case BitsTail of + [] -> {0, 0}; + [Bits] -> N = bit_size(Bits), + <<Byte:N>> = Bits, + {N, Byte} + end, + {'$used', + {{'$used',BytesList,list_to_binary(BytesList)}, NumBits, TailByte}, + BitString}. + +%% @private +-spec bitstring_len_gen(length()) -> proper_types:type(). +bitstring_len_gen(Len) -> + BytesLen = Len div 8, + BitsLen = Len rem 8, + ?LET({BytesHead, NumBits, TailByte}, + {proper_types:binary(BytesLen), BitsLen, + proper_types:range(0, 1 bsl BitsLen - 1)}, + <<BytesHead/binary, TailByte:NumBits>>). + +%% @private +-spec list_gen(size(), proper_types:type()) -> [imm_instance()]. +list_gen(Size, ElemType) -> + Len = proper_arith:rand_int(0, Size), + vector_gen(Len, ElemType). + +%% @private +-spec distlist_gen(size(), sized_generator(), boolean()) -> [imm_instance()]. +distlist_gen(RawSize, Gen, NonEmpty) -> + Len = case NonEmpty of + true -> proper_arith:rand_int(1, erlang:max(1,RawSize)); + false -> proper_arith:rand_int(0, RawSize) + end, + Size = case Len of + 1 -> RawSize - 1; + _ -> RawSize + end, + %% TODO: this produces a lot of types: maybe a simple 'div' is sufficient? + Sizes = proper_arith:distribute(Size, Len), + InnerTypes = [Gen(S) || S <- Sizes], + fixed_list_gen(InnerTypes). + +%% @private +-spec vector_gen(length(), proper_types:type()) -> [imm_instance()]. +vector_gen(Len, ElemType) -> + vector_gen_tr(Len, ElemType, []). + +-spec vector_gen_tr(length(), proper_types:type(), [imm_instance()]) -> + [imm_instance()]. +vector_gen_tr(0, _ElemType, AccList) -> + AccList; +vector_gen_tr(Left, ElemType, AccList) -> + vector_gen_tr(Left - 1, ElemType, [generate(ElemType) | AccList]). + +%% @private +-spec union_gen([proper_types:type(),...]) -> imm_instance(). +union_gen(Choices) -> + {_Choice,Type} = proper_arith:rand_choose(Choices), + generate(Type). + +%% @private +-spec weighted_union_gen([{frequency(),proper_types:type()},...]) -> + imm_instance(). +weighted_union_gen(FreqChoices) -> + {_Choice,Type} = proper_arith:freq_choose(FreqChoices), + generate(Type). + +%% @private +-spec safe_union_gen([proper_types:type(),...]) -> imm_instance(). +safe_union_gen(Choices) -> + {Choice,Type} = proper_arith:rand_choose(Choices), + try generate(Type) + catch + error:_ -> + safe_union_gen(proper_arith:list_remove(Choice, Choices)) + end. + +%% @private +-spec safe_weighted_union_gen([{frequency(),proper_types:type()},...]) -> + imm_instance(). +safe_weighted_union_gen(FreqChoices) -> + {Choice,Type} = proper_arith:freq_choose(FreqChoices), + try generate(Type) + catch + error:_ -> + safe_weighted_union_gen(proper_arith:list_remove(Choice, + FreqChoices)) + end. + +%% @private +-spec tuple_gen([proper_types:type()]) -> tuple(). +tuple_gen(Fields) -> + list_to_tuple(fixed_list_gen(Fields)). + +%% @private +-spec loose_tuple_gen(size(), proper_types:type()) -> proper_types:type(). +loose_tuple_gen(Size, ElemType) -> + ?LET(L, + proper_types:resize(Size, proper_types:list(ElemType)), + list_to_tuple(L)). + +%% @private +-spec loose_tuple_rev(tuple(), proper_types:type()) -> imm_instance(). +loose_tuple_rev(Tuple, ElemType) -> + CleanList = tuple_to_list(Tuple), + List = case proper_types:find_prop(reverse_gen, ElemType) of + {ok,{typed, ReverseGen}} -> + [ReverseGen(ElemType,X) || X <- CleanList]; + {ok,ReverseGen} -> [ReverseGen(X) || X <- CleanList]; + error -> CleanList + end, + {'$used', List, Tuple}. + +%% @private +-spec exactly_gen(T) -> T. +exactly_gen(X) -> + X. + +%% @private +-spec fixed_list_gen([proper_types:type()]) -> imm_instance() + ; ({[proper_types:type()],proper_types:type()}) -> + maybe_improper_list(imm_instance(), imm_instance() | []). +fixed_list_gen({ProperHead,ImproperTail}) -> + [generate(F) || F <- ProperHead] ++ generate(ImproperTail); +fixed_list_gen(ProperFields) -> + [generate(F) || F <- ProperFields]. + +%% @private +-spec function_gen(arity(), proper_types:type()) -> function(). +function_gen(Arity, RetType) -> + FunSeed = {proper_arith:rand_int(0, ?SEED_RANGE - 1), + proper_arith:rand_int(0, ?SEED_RANGE - 1)}, + create_fun(Arity, RetType, FunSeed). + +%% @private +-spec any_gen(size()) -> imm_instance(). +any_gen(Size) -> + case get('$any_type') of + undefined -> real_any_gen(Size); + {type,AnyType} -> generate(proper_types:resize(Size, AnyType)) + end. + +-spec real_any_gen(size()) -> imm_instance(). +real_any_gen(0) -> + SimpleTypes = [proper_types:integer(), proper_types:float(), + proper_types:atom()], + union_gen(SimpleTypes); +real_any_gen(Size) -> + FreqChoices = [{?ANY_SIMPLE_PROB,simple}, {?ANY_BINARY_PROB,binary}, + {?ANY_EXPAND_PROB,expand}], + case proper_arith:freq_choose(FreqChoices) of + {_,simple} -> + real_any_gen(0); + {_,binary} -> + generate(proper_types:resize(Size, proper_types:bitstring())); + {_,expand} -> + %% TODO: statistics of produced terms? + NumElems = proper_arith:rand_int(0, Size - 1), + ElemSizes = proper_arith:distribute(Size - 1, NumElems), + ElemTypes = [?LAZY(real_any_gen(S)) || S <- ElemSizes], + case proper_arith:rand_int(1,2) of + 1 -> fixed_list_gen(ElemTypes); + 2 -> tuple_gen(ElemTypes) + end + end. + +%% @private +-spec native_type_gen(mod_name(), string()) -> proper_types:type(). +native_type_gen(Mod, TypeStr) -> + case proper_typeserver:translate_type({Mod,TypeStr}) of + {ok,Type} -> Type; + {error,Reason} -> throw({'$typeserver',Reason}) + end. + + +%%------------------------------------------------------------------------------ +%% Function-generation functions +%%------------------------------------------------------------------------------ + +-spec create_fun(arity(), proper_types:type(), fun_seed()) -> function(). +create_fun(_Arity, _RetType, _FunSeed) -> + fun() -> throw('$arity_limit') end. + +%% @private +-spec get_ret_type(function()) -> proper_types:type(). +get_ret_type(Fun) -> + {arity,Arity} = erlang:fun_info(Fun, arity), + put('$get_ret_type', true), + RetType = apply(Fun, lists:duplicate(Arity,dummy)), + erase('$get_ret_type'), + RetType. diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_internal.hrl b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_internal.hrl new file mode 100644 index 0000000000..89e6b34296 --- /dev/null +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_internal.hrl @@ -0,0 +1,98 @@ +%%% Copyright 2010-2013 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2016 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis +%%% @doc Internal header file: This header is included in all PropEr source +%%% files. + +-include("compile_flags.hrl"). +-include("proper_common.hrl"). + + +%%------------------------------------------------------------------------------ +%% Activate strip_types parse transform +%%------------------------------------------------------------------------------ + +-ifdef(NO_TYPES). +-compile({parse_transform, strip_types}). +-endif. + +%%------------------------------------------------------------------------------ +%% Random generator selection +%%------------------------------------------------------------------------------ + +-ifdef(USE_SFMT). +-define(RANDOM_MOD, sfmt). +-define(SEED_NAME, sfmt_seed). +-else. +-define(RANDOM_MOD, random). +-define(SEED_NAME, random_seed). +-endif. + +%%------------------------------------------------------------------------------ +%% Macros +%%------------------------------------------------------------------------------ + +-define(PROPERTY_PREFIX, "prop_"). + + +%%------------------------------------------------------------------------------ +%% Constants +%%------------------------------------------------------------------------------ + +-define(SEED_RANGE, 4294967296). +-define(MAX_ARITY, 20). +-define(MAX_TRIES_FACTOR, 5). +-define(ANY_SIMPLE_PROB, 3). +-define(ANY_BINARY_PROB, 1). +-define(ANY_EXPAND_PROB, 8). +-define(SMALL_RANGE_THRESHOLD, 16#FFFF). + + +%%------------------------------------------------------------------------------ +%% Common type aliases +%%------------------------------------------------------------------------------ + +%% TODO: Perhaps these should be moved inside modules. +-type mod_name() :: atom(). +-type fun_name() :: atom(). +-type size() :: non_neg_integer(). +-type length() :: non_neg_integer(). +-type position() :: pos_integer(). +-type frequency() :: pos_integer(). +-type seed() :: {non_neg_integer(), non_neg_integer(), non_neg_integer()}. + +-type abs_form() :: erl_parse:abstract_form(). +-type abs_expr() :: erl_parse:abstract_expr(). +-type abs_clause() :: erl_parse:abstract_clause(). + +%% TODO: Replace these with the appropriate types from stdlib. +-ifdef(AT_LEAST_19). +-type abs_type() :: erl_parse:abstract_type(). +-type abs_rec_field() :: term(). % erl_parse:af_field_decl(). +-else. +-type abs_type() :: term(). +-type abs_rec_field() :: term(). +-endif. + +-type loose_tuple(T) :: {} | {T} | {T,T} | {T,T,T} | {T,T,T,T} | {T,T,T,T,T} + | {T,T,T,T,T,T} | {T,T,T,T,T,T,T} | {T,T,T,T,T,T,T,T} + | {T,T,T,T,T,T,T,T,T} | {T,T,T,T,T,T,T,T,T,T} | tuple(). diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_types.erl b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_types.erl new file mode 100644 index 0000000000..6b154b813b --- /dev/null +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_types.erl @@ -0,0 +1,1353 @@ +%%% Copyright 2010-2013 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2013 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis + +%%% @doc Type manipulation functions and predefined types. +%%% +%%% == Basic types == +%%% This module defines all the basic types of the PropEr type system as +%%% functions. See the <a href="#index">function index</a> for an overview. +%%% +%%% Types can be combined in tuples or lists to produce other types. Exact +%%% values (such as exact numbers, atoms, binaries and strings) can be combined +%%% with types inside such structures, like in this example of the type of a +%%% tagged tuple: ``{'result', integer()}''. +%%% +%%% When including the PropEr header file, all +%%% <a href="#index">API functions</a> of this module are automatically +%%% imported, unless `PROPER_NO_IMPORTS' is defined. +%%% +%%% == Customized types == +%%% The following operators can be applied to basic types in order to produce +%%% new ones: +%%% +%%% <dl> +%%% <dt>`?LET(<Xs>, <Xs_type>, <In>)'</dt> +%%% <dd>To produce an instance of this type, all appearances of the variables +%%% in `<Xs>' are replaced inside `<In>' by their corresponding values in a +%%% randomly generated instance of `<Xs_type>'. It's OK for the `<In>' part to +%%% evaluate to a type - in that case, an instance of the inner type is +%%% generated recursively.</dd> +%%% <dt>`?SUCHTHAT(<X>, <Type>, <Condition>)'</dt> +%%% <dd>This produces a specialization of `<Type>', which only includes those +%%% members of `<Type>' that satisfy the constraint `<Condition>' - that is, +%%% those members for which the function `fun(<X>) -> <Condition> end' returns +%%% `true'. If the constraint is very strict - that is, only a small +%%% percentage of instances of `<Type>' pass the test - it will take a lot of +%%% tries for the instance generation subsystem to randomly produce a valid +%%% instance. This will result in slower testing, and testing may even be +%%% stopped short, in case the `constraint_tries' limit is reached (see the +%%% "Options" section in the documentation of the {@link proper} module). If +%%% this is the case, it would be more appropriate to generate valid instances +%%% of the specialized type using the `?LET' macro. Also make sure that even +%%% small instances can satisfy the constraint, since PropEr will only try +%%% small instances at the start of testing. If this is not possible, you can +%%% instruct PropEr to start at a larger size, by supplying a suitable value +%%% for the `start_size' option (see the "Options" section in the +%%% documentation of the {@link proper} module).</dd> +%%% <dt>`?SUCHTHATMAYBE(<X>, <Type>, <Condition>)'</dt> +%%% <dd>Equivalent to the `?SUCHTHAT' macro, but the constraint `<Condition>' +%%% is considered non-strict: if the `constraint_tries' limit is reached, the +%%% generator will just return an instance of `<Type>' instead of failing, +%%% even if that instance doesn't satisfy the constraint.</dd> +%%% <dt>`?SHRINK(<Generator>, <List_of_alt_gens>)'</dt> +%%% <dd>This creates a type whose instances are generated by evaluating the +%%% statement block `<Generator>' (this may evaluate to a type, which will +%%% then be generated recursively). If an instance of such a type is to be +%%% shrunk, the generators in `<List_of_alt_gens>' are first run to produce +%%% hopefully simpler instances of the type. Thus, the generators in the +%%% second argument should be simpler than the default. The simplest ones +%%% should be at the front of the list, since those are the generators +%%% preferred by the shrinking subsystem. Like the main `<Generator>', the +%%% alternatives may also evaluate to a type, which is generated recursively. +%%% </dd> +%%% <dt>`?LETSHRINK(<List_of_variables>, <List_of_types>, <Generator>)'</dt> +%%% <dd>This is created by combining a `?LET' and a `?SHRINK' macro. Instances +%%% are generated by applying a randomly generated list of values inside +%%% `<Generator>' (just like a `?LET', with the added constraint that the +%%% variables and types must be provided in a list - alternatively, +%%% `<List_of_types>' may be a list or vector type). When shrinking instances +%%% of such a type, the sub-instances that were combined to produce it are +%%% first tried in place of the failing instance.</dd> +%%% <dt>`?LAZY(<Generator>)'</dt> +%%% <dd>This construct returns a type whose only purpose is to delay the +%%% evaluation of `<Generator>' (`<Generator>' can return a type, which will +%%% be generated recursively). Using this, you can simulate the lazy +%%% generation of instances: +%%% ``` stream() -> ?LAZY(frequency([ {1,[]}, {3,[0|stream()]} ])). ''' +%%% The above type produces lists of zeroes with an average length of 3. Note +%%% that, had we not enclosed the generator with a `?LAZY' macro, the +%%% evaluation would continue indefinitely, due to the eager evaluation of +%%% the Erlang language.</dd> +%%% <dt>`non_empty(<List_or_binary_type>)'</dt> +%%% <dd>See the documentation for {@link non_empty/1}.</dd> +%%% <dt>`noshrink(<Type>)'</dt> +%%% <dd>See the documentation for {@link noshrink/1}.</dd> +%%% <dt>`default(<Default_value>, <Type>)'</dt> +%%% <dd>See the documentation for {@link default/2}.</dd> +%%% <dt>`with_parameter(<Parameter>, <Value>, <Type>)'</dt> +%%% <dd>See the documentation for {@link with_parameter/3}.</dd> +%%% <dt>`with_parameters(<Param_value_pairs>, <Type>)'</dt> +%%% <dd>See the documentation for {@link with_parameters/2}.</dd> +%%% </dl> +%%% +%%% == Size manipulation == +%%% The following operators are related to the `size' parameter, which controls +%%% the maximum size of produced instances. The actual size of a produced +%%% instance is chosen randomly, but can never exceed the value of the `size' +%%% parameter at the moment of generation. A more accurate definition is the +%%% following: the maximum instance of `size S' can never be smaller than the +%%% maximum instance of `size S-1'. The actual size of an instance is measured +%%% differently for each type: the actual size of a list is its length, while +%%% the actual size of a tree may be the number of its internal nodes. Some +%%% types, e.g. unions, have no notion of size, thus their generation is not +%%% influenced by the value of `size'. The `size' parameter starts at 1 and +%%% grows automatically during testing. +%%% +%%% <dl> +%%% <dt>`?SIZED(<S>, <Generator>)'</dt> +%%% <dd>Creates a new type, whose instances are produced by replacing all +%%% appearances of the `<S>' parameter inside the statement block +%%% `<Generator>' with the value of the `size' parameter. It's OK for the +%%% `<Generator>' to return a type - in that case, an instance of the inner +%%% type is generated recursively.</dd> +%%% <dt>`resize(<New_size>, <Type>)'</dt> +%%% <dd>See the documentation for {@link resize/2}.</dd> +%%% </dl> + +-module(proper_types). +-export([is_inst/2, is_inst/3]). + +-export([integer/2, float/2, atom/0, binary/0, binary/1, bitstring/0, + bitstring/1, list/1, vector/2, union/1, weighted_union/1, tuple/1, + loose_tuple/1, exactly/1, fixed_list/1, function/2, any/0, + shrink_list/1, safe_union/1, safe_weighted_union/1]). +-export([integer/0, non_neg_integer/0, pos_integer/0, neg_integer/0, range/2, + float/0, non_neg_float/0, number/0, boolean/0, byte/0, char/0, + list/0, tuple/0, string/0, wunion/1, term/0, timeout/0, arity/0]). +-export([int/0, nat/0, largeint/0, real/0, bool/0, choose/2, elements/1, + oneof/1, frequency/1, return/1, default/2, orderedlist/1, function0/1, + function1/1, function2/1, function3/1, function4/1, + weighted_default/2]). +-export([resize/2, non_empty/1, noshrink/1]). + +-export([cook_outer/1, is_type/1, equal_types/2, is_raw_type/1, to_binary/1, + from_binary/1, get_prop/2, find_prop/2, safe_is_instance/2, + is_instance/2, unwrap/1, weakly/1, strongly/1, satisfies_all/2, + new_type/2, subtype/2]). +-export([lazy/1, sized/1, bind/3, shrinkwith/2, add_constraint/3, + native_type/2, distlist/3, with_parameter/3, with_parameters/2, + parameter/1, parameter/2]). +-export([le/2]). + +-export_type([type/0, raw_type/0, extint/0, extnum/0]). + +-include("proper_internal.hrl"). + + +%%------------------------------------------------------------------------------ +%% Comparison with erl_types +%%------------------------------------------------------------------------------ + +%% Missing types +%% ------------------- +%% will do: +%% records, maybe_improper_list(T,S), nonempty_improper_list(T,S) +%% maybe_improper_list(), maybe_improper_list(T), iolist, iodata +%% don't need: +%% nonempty_{list,string,maybe_improper_list} +%% won't do: +%% pid, port, ref, identifier, none, no_return, module, mfa, node +%% array, dict, digraph, set, gb_tree, gb_set, queue, tid + +%% Missing type information +%% ------------------------ +%% bin types: +%% other unit sizes? what about size info? +%% functions: +%% generally some fun, unspecified number of arguments but specified +%% return type +%% any: +%% doesn't cover functions and improper lists + + +%%------------------------------------------------------------------------------ +%% Type declaration macros +%%------------------------------------------------------------------------------ + +-define(BASIC(PropList), new_type(PropList,basic)). +-define(WRAPPER(PropList), new_type(PropList,wrapper)). +-define(CONSTRUCTED(PropList), new_type(PropList,constructed)). +-define(CONTAINER(PropList), new_type(PropList,container)). +-define(SUBTYPE(Type,PropList), subtype(PropList,Type)). + + +%%------------------------------------------------------------------------------ +%% Types +%%------------------------------------------------------------------------------ + +-type type_kind() :: 'basic' | 'wrapper' | 'constructed' | 'container' | atom(). +-type instance_test() :: fun((proper_gen:imm_instance()) -> boolean()) + | {'typed', + fun((proper_types:type(), + proper_gen:imm_instance()) -> boolean())}. +-type index() :: pos_integer(). +%% @alias +-type value() :: term(). +%% @private_type +%% @alias +-type extint() :: integer() | 'inf'. +%% @private_type +%% @alias +-type extnum() :: number() | 'inf'. +-type constraint_fun() :: fun((proper_gen:instance()) -> boolean()). + +-opaque type() :: {'$type', [type_prop()]}. +%% A type of the PropEr type system +%% @type raw_type(). You can consider this as an equivalent of {@type type()}. +-type raw_type() :: type() | [raw_type()] | loose_tuple(raw_type()) | term(). +-type type_prop_name() :: 'kind' | 'generator' | 'reverse_gen' | 'parts_type' + | 'combine' | 'alt_gens' | 'shrink_to_parts' + | 'size_transform' | 'is_instance' | 'shrinkers' + | 'noshrink' | 'internal_type' | 'internal_types' + | 'get_length' | 'split' | 'join' | 'get_indices' + | 'remove' | 'retrieve' | 'update' | 'constraints' + | 'parameters' | 'env' | 'subenv'. + +-type type_prop_value() :: term(). +-type type_prop() :: + {'kind', type_kind()} + | {'generator', proper_gen:generator()} + | {'reverse_gen', proper_gen:reverse_gen()} + | {'parts_type', type()} + | {'combine', proper_gen:combine_fun()} + | {'alt_gens', proper_gen:alt_gens()} + | {'shrink_to_parts', boolean()} + | {'size_transform', fun((size()) -> size())} + | {'is_instance', instance_test()} + | {'shrinkers', [proper_shrink:shrinker()]} + | {'noshrink', boolean()} + | {'internal_type', raw_type()} + | {'internal_types', tuple() | maybe_improper_list(type(),type() | [])} + %% The items returned by 'remove' must be of this type. + | {'get_length', fun((proper_gen:imm_instance()) -> length())} + %% If this is a container type, this should return the number of elements + %% it contains. + | {'split', fun((proper_gen:imm_instance()) -> [proper_gen:imm_instance()]) + | fun((length(),proper_gen:imm_instance()) -> + {proper_gen:imm_instance(),proper_gen:imm_instance()})} + %% If present, the appropriate form depends on whether get_length is + %% defined: if get_length is undefined, this must be in the one-argument + %% form (e.g. a tree should be split into its subtrees), else it must be + %% in the two-argument form (e.g. a list should be split in two at the + %% index provided). + | {'join', fun((proper_gen:imm_instance(),proper_gen:imm_instance()) -> + proper_gen:imm_instance())} + | {'get_indices', fun((proper_types:type(), + proper_gen:imm_instance()) -> [index()])} + %% If this is a container type, this should return a list of indices we + %% can use to remove or insert elements from the given instance. + | {'remove', fun((index(),proper_gen:imm_instance()) -> + proper_gen:imm_instance())} + | {'retrieve', fun((index(), proper_gen:imm_instance() | tuple() + | maybe_improper_list(type(),type() | [])) -> + value() | type())} + | {'update', fun((index(),value(),proper_gen:imm_instance()) -> + proper_gen:imm_instance())} + | {'constraints', [{constraint_fun(), boolean()}]} + %% A list of constraints on instances of this type: each constraint is a + %% tuple of a fun that must return 'true' for each valid instance and a + %% boolean field that specifies whether the condition is strict. + | {'parameters', [{atom(),value()}]} + | {'env', term()} + | {'subenv', term()}. + + +%%------------------------------------------------------------------------------ +%% Type manipulation functions +%%------------------------------------------------------------------------------ + +%% TODO: We shouldn't need the fully qualified type name in the range of these +%% functions. + +%% @private +%% TODO: just cook/1 ? +-spec cook_outer(raw_type()) -> proper_types:type(). +cook_outer(Type = {'$type',_Props}) -> + Type; +cook_outer(RawType) -> + if + is_tuple(RawType) -> tuple(tuple_to_list(RawType)); + %% CAUTION: this must handle improper lists + is_list(RawType) -> fixed_list(RawType); + %% default case (covers integers, floats, atoms, binaries, ...): + true -> exactly(RawType) + end. + +%% @private +-spec is_type(term()) -> boolean(). +is_type({'$type',_Props}) -> + true; +is_type(_) -> + false. + +%% @private +-spec equal_types(proper_types:type(), proper_types:type()) -> boolean(). +equal_types(SameType, SameType) -> + true; +equal_types(_, _) -> + false. + +%% @private +-spec is_raw_type(term()) -> boolean(). +is_raw_type({'$type',_TypeProps}) -> + true; +is_raw_type(X) -> + if + is_tuple(X) -> is_raw_type_list(tuple_to_list(X)); + is_list(X) -> is_raw_type_list(X); + true -> false + end. + +-spec is_raw_type_list(maybe_improper_list()) -> boolean(). +%% CAUTION: this must handle improper lists +is_raw_type_list(List) -> + proper_arith:safe_any(fun is_raw_type/1, List). + +%% @private +-spec to_binary(proper_types:type()) -> binary(). +to_binary(Type) -> + term_to_binary(Type). + +%% @private +-ifdef(AT_LEAST_17). +-spec from_binary(binary()) -> proper_types:type(). +-endif. +from_binary(Binary) -> + binary_to_term(Binary). + +-spec type_from_list([type_prop()]) -> proper_types:type(). +type_from_list(KeyValueList) -> + {'$type',KeyValueList}. + +-spec add_prop(type_prop_name(), type_prop_value(), proper_types:type()) -> + proper_types:type(). +add_prop(PropName, Value, {'$type',Props}) -> + {'$type',lists:keystore(PropName, 1, Props, {PropName, Value})}. + +-spec add_props([type_prop()], proper_types:type()) -> proper_types:type(). +add_props(PropList, {'$type',OldProps}) -> + {'$type', lists:foldl(fun({N,_}=NV,Acc) -> + lists:keystore(N, 1, Acc, NV) + end, OldProps, PropList)}. + +-spec append_to_prop(type_prop_name(), type_prop_value(), + proper_types:type()) -> proper_types:type(). +append_to_prop(PropName, Value, {'$type',Props}) -> + Val = case lists:keyfind(PropName, 1, Props) of + {PropName, V} -> + V; + _ -> + [] + end, + {'$type', lists:keystore(PropName, 1, Props, + {PropName, lists:reverse([Value|Val])})}. + +-spec append_list_to_prop(type_prop_name(), [type_prop_value()], + proper_types:type()) -> proper_types:type(). +append_list_to_prop(PropName, List, {'$type',Props}) -> + {PropName, Val} = lists:keyfind(PropName, 1, Props), + {'$type', lists:keystore(PropName, 1, Props, {PropName, Val++List})}. + +%% @private +-spec get_prop(type_prop_name(), proper_types:type()) -> type_prop_value(). +get_prop(PropName, {'$type',Props}) -> + {_PropName, Val} = lists:keyfind(PropName, 1, Props), + Val. + +%% @private +-spec find_prop(type_prop_name(), proper_types:type()) -> + {'ok',type_prop_value()} | 'error'. +find_prop(PropName, {'$type',Props}) -> + case lists:keyfind(PropName, 1, Props) of + {PropName, Value} -> + {ok, Value}; + _ -> + error + end. + +%% @private +-spec new_type([type_prop()], type_kind()) -> proper_types:type(). +new_type(PropList, Kind) -> + Type = type_from_list(PropList), + add_prop(kind, Kind, Type). + +%% @private +-spec subtype([type_prop()], proper_types:type()) -> proper_types:type(). +%% TODO: should the 'is_instance' function etc. be reset for subtypes? +subtype(PropList, Type) -> + add_props(PropList, Type). + +%% @private +-spec is_inst(proper_gen:instance(), raw_type()) -> + boolean() | {'error',{'typeserver',term()}}. +is_inst(Instance, RawType) -> + is_inst(Instance, RawType, 10). + +%% @private +-spec is_inst(proper_gen:instance(), raw_type(), size()) -> + boolean() | {'error',{'typeserver',term()}}. +is_inst(Instance, RawType, Size) -> + proper:global_state_init_size(Size), + Result = safe_is_instance(Instance, RawType), + proper:global_state_erase(), + Result. + +%% @private +-spec safe_is_instance(proper_gen:imm_instance(), raw_type()) -> + boolean() | {'error',{'typeserver',term()}}. +safe_is_instance(ImmInstance, RawType) -> + try is_instance(ImmInstance, RawType) catch + throw:{'$typeserver',SubReason} -> {error, {typeserver,SubReason}} + end. + +%% @private +-spec is_instance(proper_gen:imm_instance(), raw_type()) -> boolean(). +%% TODO: If the second argument is not a type, let it pass (don't even check for +%% term equality?) - if it's a raw type, don't cook it, instead recurse +%% into it. +is_instance(ImmInstance, RawType) -> + CleanInstance = proper_gen:clean_instance(ImmInstance), + Type = cook_outer(RawType), + (case get_prop(kind, Type) of + wrapper -> wrapper_test(ImmInstance, Type); + constructed -> constructed_test(ImmInstance, Type); + _ -> false + end + orelse + case find_prop(is_instance, Type) of + {ok,{typed, IsInstance}} -> IsInstance(Type, ImmInstance); + {ok,IsInstance} -> IsInstance(ImmInstance); + error -> false + end) + andalso weakly(satisfies_all(CleanInstance, Type)). + +-spec wrapper_test(proper_gen:imm_instance(), proper_types:type()) -> boolean(). +wrapper_test(ImmInstance, Type) -> + %% TODO: check if it's actually a raw type that's returned? + lists:any(fun(T) -> is_instance(ImmInstance, T) end, unwrap(Type)). + +%% @private +-ifdef(AT_LEAST_17). +-spec unwrap(proper_types:type()) -> [proper_types:type(),...]. +-endif. +%% TODO: check if it's actually a raw type that's returned? +unwrap(Type) -> + RawInnerTypes = proper_gen:alt_gens(Type) ++ [proper_gen:normal_gen(Type)], + [cook_outer(T) || T <- RawInnerTypes]. + +-spec constructed_test(proper_gen:imm_instance(), proper_types:type()) -> + boolean(). +constructed_test({'$used',ImmParts,ImmInstance}, Type) -> + PartsType = get_prop(parts_type, Type), + Combine = get_prop(combine, Type), + is_instance(ImmParts, PartsType) andalso + begin + %% TODO: check if it's actually a raw type that's returned? + %% TODO: move construction code to proper_gen + %% TODO: non-type => should we check for strict term equality? + RawInnerType = Combine(proper_gen:clean_instance(ImmParts)), + is_instance(ImmInstance, RawInnerType) + end; +constructed_test({'$to_part',ImmInstance}, Type) -> + PartsType = get_prop(parts_type, Type), + get_prop(shrink_to_parts, Type) =:= true andalso + %% TODO: we reject non-container types + get_prop(kind, PartsType) =:= container andalso + case {find_prop(internal_type,PartsType), + find_prop(internal_types,PartsType)} of + {{ok,EachPartType},error} -> + %% The parts are in a list or a vector. + is_instance(ImmInstance, EachPartType); + {error,{ok,PartTypesList}} -> + %% The parts are in a fixed list. + %% TODO: It should always be a proper list. + lists:any(fun(T) -> is_instance(ImmInstance,T) end, PartTypesList) + end; +constructed_test(_CleanInstance, _Type) -> + %% TODO: can we do anything better? + false. + +%% @private +-spec weakly({boolean(),boolean()}) -> boolean(). +weakly({B1,_B2}) -> B1. + +%% @private +-spec strongly({boolean(),boolean()}) -> boolean(). +strongly({_B1,B2}) -> B2. + +-spec satisfies(proper_gen:instance(), {constraint_fun(),boolean()}) + -> {boolean(),boolean()}. +satisfies(Instance, {Test,false}) -> + {true,Test(Instance)}; +satisfies(Instance, {Test,true}) -> + Result = Test(Instance), + {Result,Result}. + +%% @private +-spec satisfies_all(proper_gen:instance(), proper_types:type()) -> + {boolean(),boolean()}. +satisfies_all(Instance, Type) -> + case find_prop(constraints, Type) of + {ok, Constraints} -> + L = [satisfies(Instance, C) || C <- Constraints], + {L1,L2} = lists:unzip(L), + {lists:all(fun(B) -> B end, L1), lists:all(fun(B) -> B end, L2)}; + error -> + {true,true} + end. + + +%%------------------------------------------------------------------------------ +%% Type definition functions +%%------------------------------------------------------------------------------ + +%% @private +-spec lazy(proper_gen:nosize_generator()) -> proper_types:type(). +lazy(Gen) -> + ?WRAPPER([ + {generator, Gen} + ]). + +%% @private +-spec sized(proper_gen:sized_generator()) -> proper_types:type(). +sized(Gen) -> + ?WRAPPER([ + {generator, Gen} + ]). + +%% @private +-spec bind(raw_type(), proper_gen:combine_fun(), boolean()) -> + proper_types:type(). +bind(RawPartsType, Combine, ShrinkToParts) -> + PartsType = cook_outer(RawPartsType), + ?CONSTRUCTED([ + {parts_type, PartsType}, + {combine, Combine}, + {shrink_to_parts, ShrinkToParts} + ]). + +%% @private +-spec shrinkwith(proper_gen:nosize_generator(), proper_gen:alt_gens()) -> + proper_types:type(). +shrinkwith(Gen, DelaydAltGens) -> + ?WRAPPER([ + {generator, Gen}, + {alt_gens, DelaydAltGens} + ]). + +%% @private +-spec add_constraint(raw_type(), constraint_fun(), boolean()) -> + proper_types:type(). +add_constraint(RawType, Condition, IsStrict) -> + Type = cook_outer(RawType), + append_to_prop(constraints, {Condition,IsStrict}, Type). + +%% @private +-spec native_type(mod_name(), string()) -> proper_types:type(). +native_type(Mod, TypeStr) -> + ?WRAPPER([ + {generator, fun() -> proper_gen:native_type_gen(Mod,TypeStr) end} + ]). + + +%%------------------------------------------------------------------------------ +%% Basic types +%%------------------------------------------------------------------------------ + +%% @doc All integers between `Low' and `High', bounds included. +%% `Low' and `High' must be Erlang expressions that evaluate to integers, with +%% `Low =< High'. Additionally, `Low' and `High' may have the value `inf', in +%% which case they represent minus infinity and plus infinity respectively. +%% Instances shrink towards 0 if `Low =< 0 =< High', or towards the bound with +%% the smallest absolute value otherwise. +-spec integer(extint(), extint()) -> proper_types:type(). +integer(Low, High) -> + ?BASIC([ + {env, {Low, High}}, + {generator, {typed, fun integer_gen/2}}, + {is_instance, {typed, fun integer_is_instance/2}}, + {shrinkers, [fun number_shrinker/3]} + ]). + +integer_gen(Type, Size) -> + {Low, High} = get_prop(env, Type), + proper_gen:integer_gen(Size, Low, High). + +integer_is_instance(Type, X) -> + {Low, High} = get_prop(env, Type), + is_integer(X) andalso le(Low, X) andalso le(X, High). + +number_shrinker(X, Type, S) -> + {Low, High} = get_prop(env, Type), + proper_shrink:number_shrinker(X, Low, High, S). + +%% @doc All floats between `Low' and `High', bounds included. +%% `Low' and `High' must be Erlang expressions that evaluate to floats, with +%% `Low =< High'. Additionally, `Low' and `High' may have the value `inf', in +%% which case they represent minus infinity and plus infinity respectively. +%% Instances shrink towards 0.0 if `Low =< 0.0 =< High', or towards the bound +%% with the smallest absolute value otherwise. +-spec float(extnum(), extnum()) -> proper_types:type(). +float(Low, High) -> + ?BASIC([ + {env, {Low, High}}, + {generator, {typed, fun float_gen/2}}, + {is_instance, {typed, fun float_is_instance/2}}, + {shrinkers, [fun number_shrinker/3]} + ]). + +float_gen(Type, Size) -> + {Low, High} = get_prop(env, Type), + proper_gen:float_gen(Size, Low, High). + +float_is_instance(Type, X) -> + {Low, High} = get_prop(env, Type), + is_float(X) andalso le(Low, X) andalso le(X, High). + +%% @private +-spec le(extnum(), extnum()) -> boolean(). +le(inf, _B) -> true; +le(_A, inf) -> true; +le(A, B) -> A =< B. + +%% @doc All atoms. All atoms used internally by PropEr start with a '`$'', so +%% such atoms will never be produced as instances of this type. You should also +%% refrain from using such atoms in your code, to avoid a potential clash. +%% Instances shrink towards the empty atom, ''. +-spec atom() -> proper_types:type(). +atom() -> + ?WRAPPER([ + {generator, fun proper_gen:atom_gen/1}, + {reverse_gen, fun proper_gen:atom_rev/1}, + {size_transform, fun(Size) -> erlang:min(Size,255) end}, + {is_instance, fun atom_is_instance/1} + ]). + +atom_is_instance(X) -> + is_atom(X) + %% We return false for atoms starting with '$', since these are + %% atoms used internally and never produced by the atom generator. + andalso (X =:= '' orelse hd(atom_to_list(X)) =/= $$). + +%% @doc All binaries. Instances shrink towards the empty binary, `<<>>'. +-spec binary() -> proper_types:type(). +binary() -> + ?WRAPPER([ + {generator, fun proper_gen:binary_gen/1}, + {reverse_gen, fun proper_gen:binary_rev/1}, + {is_instance, fun erlang:is_binary/1} + ]). + +%% @doc All binaries with a byte size of `Len'. +%% `Len' must be an Erlang expression that evaluates to a non-negative integer. +%% Instances shrink towards binaries of zeroes. +-spec binary(length()) -> proper_types:type(). +binary(Len) -> + ?WRAPPER([ + {env, Len}, + {generator, {typed, fun binary_len_gen/1}}, + {reverse_gen, fun proper_gen:binary_rev/1}, + {is_instance, {typed, fun binary_len_is_instance/2}} + ]). + +binary_len_gen(Type) -> + Len = get_prop(env, Type), + proper_gen:binary_len_gen(Len). + +binary_len_is_instance(Type, X) -> + Len = get_prop(env, Type), + is_binary(X) andalso byte_size(X) =:= Len. + +%% @doc All bitstrings. Instances shrink towards the empty bitstring, `<<>>'. +-spec bitstring() -> proper_types:type(). +bitstring() -> + ?WRAPPER([ + {generator, fun proper_gen:bitstring_gen/1}, + {reverse_gen, fun proper_gen:bitstring_rev/1}, + {is_instance, fun erlang:is_bitstring/1} + ]). + +%% @doc All bitstrings with a bit size of `Len'. +%% `Len' must be an Erlang expression that evaluates to a non-negative integer. +%% Instances shrink towards bitstrings of zeroes +-spec bitstring(length()) -> proper_types:type(). +bitstring(Len) -> + ?WRAPPER([ + {env, Len}, + {generator, {typed, fun bitstring_len_gen/1}}, + {reverse_gen, fun proper_gen:bitstring_rev/1}, + {is_instance, {typed, fun bitstring_len_is_instance/2}} + ]). + +bitstring_len_gen(Type) -> + Len = get_prop(env, Type), + proper_gen:bitstring_len_gen(Len). + +bitstring_len_is_instance(Type, X) -> + Len = get_prop(env, Type), + is_bitstring(X) andalso bit_size(X) =:= Len. + +%% @doc All lists containing elements of type `ElemType'. +%% Instances shrink towards the empty list, `[]'. +-spec list(ElemType::raw_type()) -> proper_types:type(). +% TODO: subtyping would be useful here (list, vector, fixed_list) +list(RawElemType) -> + ElemType = cook_outer(RawElemType), + ?CONTAINER([ + {generator, {typed, fun list_gen/2}}, + {is_instance, {typed, fun list_is_instance/2}}, + {internal_type, ElemType}, + {get_length, fun erlang:length/1}, + {split, fun lists:split/2}, + {join, fun lists:append/2}, + {get_indices, fun list_get_indices/2}, + {remove, fun proper_arith:list_remove/2}, + {retrieve, fun lists:nth/2}, + {update, fun proper_arith:list_update/3} + ]). + +list_gen(Type, Size) -> + ElemType = get_prop(internal_type, Type), + proper_gen:list_gen(Size, ElemType). + +list_is_instance(Type, X) -> + ElemType = get_prop(internal_type, Type), + list_test(X, ElemType). + +%% @doc A type that generates exactly the list `List'. Instances shrink towards +%% shorter sublists of the original list. +-spec shrink_list([term()]) -> proper_types:type(). +shrink_list(List) -> + ?CONTAINER([ + {env, List}, + {generator, {typed, fun shrink_list_gen/1}}, + {is_instance, {typed, fun shrink_list_is_instance/2}}, + {get_length, fun erlang:length/1}, + {split, fun lists:split/2}, + {join, fun lists:append/2}, + {get_indices, fun list_get_indices/2}, + {remove, fun proper_arith:list_remove/2} + ]). + +shrink_list_gen(Type) -> + get_prop(env, Type). + +shrink_list_is_instance(Type, X) -> + List = get_prop(env, Type), + is_sublist(X, List). + +-spec is_sublist([term()], [term()]) -> boolean(). +is_sublist([], _) -> true; +is_sublist(_, []) -> false; +is_sublist([H|T1], [H|T2]) -> is_sublist(T1, T2); +is_sublist(Slice, [_|T2]) -> is_sublist(Slice, T2). + +-spec list_test(proper_gen:imm_instance(), proper_types:type()) -> boolean(). +list_test(X, ElemType) -> + is_list(X) andalso lists:all(fun(E) -> is_instance(E, ElemType) end, X). + +%% @private +-spec list_get_indices(proper_gen:generator(), list()) -> [position()]. +list_get_indices(_, List) -> + lists:seq(1, length(List)). + +%% @private +%% This assumes that: +%% - instances of size S are always valid instances of size >S +%% - any recursive calls inside Gen are lazy +-spec distlist(size(), proper_gen:sized_generator(), boolean()) -> + proper_types:type(). +distlist(Size, Gen, NonEmpty) -> + ParentType = case NonEmpty of + true -> non_empty(list(Gen(Size))); + false -> list(Gen(Size)) + end, + ?SUBTYPE(ParentType, [ + {subenv, {Size, Gen, NonEmpty}}, + {generator, {typed, fun distlist_gen/1}} + ]). + +distlist_gen(Type) -> + {Size, Gen, NonEmpty} = get_prop(subenv, Type), + proper_gen:distlist_gen(Size, Gen, NonEmpty). + +%% @doc All lists of length `Len' containing elements of type `ElemType'. +%% `Len' must be an Erlang expression that evaluates to a non-negative integer. +-spec vector(length(), ElemType::raw_type()) -> proper_types:type(). +vector(Len, RawElemType) -> + ElemType = cook_outer(RawElemType), + ?CONTAINER([ + {env, Len}, + {generator, {typed, fun vector_gen/1}}, + {is_instance, {typed, fun vector_is_instance/2}}, + {internal_type, ElemType}, + {get_indices, fun vector_get_indices/2}, + {retrieve, fun lists:nth/2}, + {update, fun proper_arith:list_update/3} + ]). + +vector_gen(Type) -> + Len = get_prop(env, Type), + ElemType = get_prop(internal_type, Type), + proper_gen:vector_gen(Len, ElemType). + +vector_is_instance(Type, X) -> + Len = get_prop(env, Type), + ElemType = get_prop(internal_type, Type), + is_list(X) + andalso length(X) =:= Len + andalso lists:all(fun(E) -> is_instance(E, ElemType) end, X). + +vector_get_indices(Type, _X) -> + lists:seq(1, get_prop(env, Type)). + +%% @doc The union of all types in `ListOfTypes'. `ListOfTypes' can't be empty. +%% The random instance generator is equally likely to choose any one of the +%% types in `ListOfTypes'. The shrinking subsystem will always try to shrink an +%% instance of a type union to an instance of the first type in `ListOfTypes', +%% thus you should write the simplest case first. +-spec union(ListOfTypes::[raw_type(),...]) -> proper_types:type(). +union(RawChoices) -> + Choices = [cook_outer(C) || C <- RawChoices], + ?BASIC([ + {env, Choices}, + {generator, {typed, fun union_gen/1}}, + {is_instance, {typed, fun union_is_instance/2}}, + {shrinkers, [fun union_shrinker_1/3, fun union_shrinker_2/3]} + ]). + +union_gen(Type) -> + Choices = get_prop(env,Type), + proper_gen:union_gen(Choices). + +union_is_instance(Type, X) -> + Choices = get_prop(env, Type), + lists:any(fun(C) -> is_instance(X, C) end, Choices). + +union_shrinker_1(X, Type, S) -> + Choices = get_prop(env, Type), + proper_shrink:union_first_choice_shrinker(X, Choices, S). + +union_shrinker_2(X, Type, S) -> + Choices = get_prop(env, Type), + proper_shrink:union_recursive_shrinker(X, Choices, S). + +%% @doc A specialization of {@link union/1}, where each type in `ListOfTypes' is +%% assigned a frequency. Frequencies must be Erlang expressions that evaluate to +%% positive integers. Types with larger frequencies are more likely to be chosen +%% by the random instance generator. The shrinking subsystem will ignore the +%% frequencies and try to shrink towards the first type in the list. +-spec weighted_union(ListOfTypes::[{frequency(),raw_type()},...]) -> + proper_types:type(). +weighted_union(RawFreqChoices) -> + CookFreqType = fun({Freq,RawType}) -> {Freq,cook_outer(RawType)} end, + FreqChoices = lists:map(CookFreqType, RawFreqChoices), + Choices = [T || {_F,T} <- FreqChoices], + ?SUBTYPE(union(Choices), [ + {subenv, FreqChoices}, + {generator, {typed, fun weighted_union_gen/1}} + ]). + +weighted_union_gen(Gen) -> + FreqChoices = get_prop(subenv, Gen), + proper_gen:weighted_union_gen(FreqChoices). + +%% @private +-spec safe_union([raw_type(),...]) -> proper_types:type(). +safe_union(RawChoices) -> + Choices = [cook_outer(C) || C <- RawChoices], + subtype( + [{subenv, Choices}, + {generator, {typed, fun safe_union_gen/1}}], + union(Choices)). + +safe_union_gen(Type) -> + Choices = get_prop(subenv, Type), + proper_gen:safe_union_gen(Choices). + +%% @private +-spec safe_weighted_union([{frequency(),raw_type()},...]) -> + proper_types:type(). +safe_weighted_union(RawFreqChoices) -> + CookFreqType = fun({Freq,RawType}) -> + {Freq,cook_outer(RawType)} end, + FreqChoices = lists:map(CookFreqType, RawFreqChoices), + Choices = [T || {_F,T} <- FreqChoices], + subtype([{subenv, FreqChoices}, + {generator, {typed, fun safe_weighted_union_gen/1}}], + union(Choices)). + +safe_weighted_union_gen(Type) -> + FreqChoices = get_prop(subenv, Type), + proper_gen:safe_weighted_union_gen(FreqChoices). + +%% @doc All tuples whose i-th element is an instance of the type at index i of +%% `ListOfTypes'. Also written simply as a tuple of types. +-spec tuple(ListOfTypes::[raw_type()]) -> proper_types:type(). +tuple(RawFields) -> + Fields = [cook_outer(F) || F <- RawFields], + ?CONTAINER([ + {env, Fields}, + {generator, {typed, fun tuple_gen/1}}, + {is_instance, {typed, fun tuple_is_instance/2}}, + {internal_types, list_to_tuple(Fields)}, + {get_indices, fun tuple_get_indices/2}, + {retrieve, fun erlang:element/2}, + {update, fun tuple_update/3} + ]). + +tuple_gen(Type) -> + Fields = get_prop(env, Type), + proper_gen:tuple_gen(Fields). + +tuple_is_instance(Type, X) -> + Fields = get_prop(env, Type), + is_tuple(X) andalso fixed_list_test(tuple_to_list(X), Fields). + +tuple_get_indices(Type, _X) -> + lists:seq(1, length(get_prop(env, Type))). + +-spec tuple_update(index(), value(), tuple()) -> tuple(). +tuple_update(Index, NewElem, Tuple) -> + setelement(Index, Tuple, NewElem). + +%% @doc Tuples whose elements are all of type `ElemType'. +%% Instances shrink towards the 0-size tuple, `{}'. +-spec loose_tuple(ElemType::raw_type()) -> proper_types:type(). +loose_tuple(RawElemType) -> + ElemType = cook_outer(RawElemType), + ?WRAPPER([ + {env, ElemType}, + {generator, {typed, fun loose_tuple_gen/2}}, + {reverse_gen, {typed, fun loose_tuple_rev/2}}, + {is_instance, {typed, fun loose_tuple_is_instance/2}} + ]). + +loose_tuple_gen(Type, Size) -> + ElemType = get_prop(env, Type), + proper_gen:loose_tuple_gen(Size, ElemType). + +loose_tuple_rev(Type, X) -> + ElemType = get_prop(env, Type), + proper_gen:loose_tuple_rev(X, ElemType). + +loose_tuple_is_instance(Type, X) -> + ElemType = get_prop(env, Type), + is_tuple(X) andalso list_test(tuple_to_list(X), ElemType). + +%% @doc Singleton type consisting only of `E'. `E' must be an evaluated term. +%% Also written simply as `E'. +-spec exactly(term()) -> proper_types:type(). +exactly(E) -> + ?BASIC([ + {env, E}, + {generator, {typed, fun exactly_gen/1}}, + {is_instance, {typed, fun exactly_is_instance/2}} + ]). + +exactly_gen(Type) -> + E = get_prop(env, Type), + proper_gen:exactly_gen(E). + +exactly_is_instance(Type, X) -> + E = get_prop(env, Type), + X =:= E. + +%% @doc All lists whose i-th element is an instance of the type at index i of +%% `ListOfTypes'. Also written simply as a list of types. +-spec fixed_list(ListOfTypes::maybe_improper_list(raw_type(),raw_type()|[])) -> + proper_types:type(). +fixed_list(MaybeImproperRawFields) -> + %% CAUTION: must handle improper lists + {Fields, Internal, Len, Retrieve, Update} = + case proper_arith:cut_improper_tail(MaybeImproperRawFields) of + % TODO: have cut_improper_tail return the length and use it in test? + {ProperRawHead, ImproperRawTail} -> + HeadLen = length(ProperRawHead), + CookedHead = [cook_outer(F) || F <- ProperRawHead], + CookedTail = cook_outer(ImproperRawTail), + {{CookedHead,CookedTail}, + CookedHead ++ CookedTail, + HeadLen + 1, + fun(I,L) -> improper_list_retrieve(I, L, HeadLen) end, + fun(I,V,L) -> improper_list_update(I, V, L, HeadLen) end}; + ProperRawFields -> + LocalFields = [cook_outer(F) || F <- ProperRawFields], + {LocalFields, + LocalFields, + length(ProperRawFields), + fun lists:nth/2, + fun proper_arith:list_update/3} + end, + ?CONTAINER([ + {env, {Fields, Len}}, + {generator, {typed, fun fixed_list_gen/1}}, + {is_instance, {typed, fun fixed_list_is_instance/2}}, + {internal_types, Internal}, + {get_indices, fun fixed_list_get_indices/2}, + {retrieve, Retrieve}, + {update, Update} + ]). + +fixed_list_gen(Type) -> + {Fields, _} = get_prop(env, Type), + proper_gen:fixed_list_gen(Fields). + +fixed_list_is_instance(Type, X) -> + {Fields, _} = get_prop(env, Type), + fixed_list_test(X, Fields). + +fixed_list_get_indices(Type, _X) -> + {_, Len} = get_prop(env, Type), + lists:seq(1, Len). + +-spec fixed_list_test(proper_gen:imm_instance(), + [proper_types:type()] | {[proper_types:type()], + proper_types:type()}) -> + boolean(). +fixed_list_test(X, {ProperHead,ImproperTail}) -> + is_list(X) andalso + begin + ProperHeadLen = length(ProperHead), + proper_arith:head_length(X) >= ProperHeadLen andalso + begin + {XHead,XTail} = lists:split(ProperHeadLen, X), + fixed_list_test(XHead, ProperHead) + andalso is_instance(XTail, ImproperTail) + end + end; +fixed_list_test(X, ProperFields) -> + is_list(X) + andalso length(X) =:= length(ProperFields) + andalso lists:all(fun({E,T}) -> is_instance(E, T) end, + lists:zip(X, ProperFields)). + +%% TODO: Move these 2 functions to proper_arith? +-spec improper_list_retrieve(index(), nonempty_improper_list(value(),value()), + pos_integer()) -> value(). +improper_list_retrieve(Index, List, HeadLen) -> + case Index =< HeadLen of + true -> lists:nth(Index, List); + false -> lists:nthtail(HeadLen, List) + end. + +-spec improper_list_update(index(), value(), + nonempty_improper_list(value(),value()), + pos_integer()) -> + nonempty_improper_list(value(),value()). +improper_list_update(Index, Value, List, HeadLen) -> + case Index =< HeadLen of + %% TODO: This happens to work, but is not implied by list_update's spec. + true -> proper_arith:list_update(Index, Value, List); + false -> lists:sublist(List, HeadLen) ++ Value + end. + +%% @doc All pure functions that map instances of `ArgTypes' to instances of +%% `RetType'. The syntax `function(Arity, RetType)' is also acceptable. +-spec function(ArgTypes::[raw_type()] | arity(), RetType::raw_type()) -> + proper_types:type(). +function(Arity, RawRetType) when is_integer(Arity), Arity >= 0, Arity =< 255 -> + RetType = cook_outer(RawRetType), + ?BASIC([ + {env, {Arity, RetType}}, + {generator, {typed, fun function_gen/1}}, + {is_instance, {typed, fun function_is_instance/2}} + ]); +function(RawArgTypes, RawRetType) -> + function(length(RawArgTypes), RawRetType). + +function_gen(Type) -> + {Arity, RetType} = get_prop(env, Type), + proper_gen:function_gen(Arity, RetType). + +function_is_instance(Type, X) -> + {Arity, RetType} = get_prop(env, Type), + is_function(X, Arity) + %% TODO: what if it's not a function we produced? + andalso equal_types(RetType, proper_gen:get_ret_type(X)). + +%% @doc All Erlang terms (that PropEr can produce). For reasons of efficiency, +%% functions are never produced as instances of this type.<br /> +%% CAUTION: Instances of this type are expensive to produce, shrink and instance- +%% check, both in terms of processing time and consumed memory. Only use this +%% type if you are certain that you need it. +-spec any() -> proper_types:type(). +any() -> + AllTypes = [integer(),float(),atom(),bitstring(),?LAZY(loose_tuple(any())), + ?LAZY(list(any()))], + ?SUBTYPE(union(AllTypes), [ + {generator, fun proper_gen:any_gen/1} + ]). + + +%%------------------------------------------------------------------------------ +%% Type aliases +%%------------------------------------------------------------------------------ + +%% @equiv integer(inf, inf) +-spec integer() -> proper_types:type(). +integer() -> integer(inf, inf). + +%% @equiv integer(0, inf) +-spec non_neg_integer() -> proper_types:type(). +non_neg_integer() -> integer(0, inf). + +%% @equiv integer(1, inf) +-spec pos_integer() -> proper_types:type(). +pos_integer() -> integer(1, inf). + +%% @equiv integer(inf, -1) +-spec neg_integer() -> proper_types:type(). +neg_integer() -> integer(inf, -1). + +%% @equiv integer(Low, High) +-spec range(extint(), extint()) -> proper_types:type(). +range(Low, High) -> integer(Low, High). + +%% @equiv float(inf, inf) +-spec float() -> proper_types:type(). +float() -> float(inf, inf). + +%% @equiv float(0.0, inf) +-spec non_neg_float() -> proper_types:type(). +non_neg_float() -> float(0.0, inf). + +%% @equiv union([integer(), float()]) +-spec number() -> proper_types:type(). +number() -> union([integer(), float()]). + +%% @doc The atoms `true' and `false'. Instances shrink towards `false'. +-spec boolean() -> proper_types:type(). +boolean() -> union(['false', 'true']). + +%% @equiv integer(0, 255) +-spec byte() -> proper_types:type(). +byte() -> integer(0, 255). + +%% @equiv integer(0, 16#10ffff) +-spec char() -> proper_types:type(). +char() -> integer(0, 16#10ffff). + +%% @equiv list(any()) +-spec list() -> proper_types:type(). +list() -> list(any()). + +%% @equiv loose_tuple(any()) +-spec tuple() -> proper_types:type(). +tuple() -> loose_tuple(any()). + +%% @equiv list(char()) +-spec string() -> proper_types:type(). +string() -> list(char()). + +%% @equiv weighted_union(FreqChoices) +-spec wunion([{frequency(),raw_type()},...]) -> proper_types:type(). +wunion(FreqChoices) -> weighted_union(FreqChoices). + +%% @equiv any() +-spec term() -> proper_types:type(). +term() -> any(). + +%% @equiv union([non_neg_integer() | infinity]) +-spec timeout() -> proper_types:type(). +timeout() -> union([non_neg_integer(), 'infinity']). + +%% @equiv integer(0, 255) +-spec arity() -> proper_types:type(). +arity() -> integer(0, 255). + + +%%------------------------------------------------------------------------------ +%% QuickCheck compatibility types +%%------------------------------------------------------------------------------ + +%% @doc Small integers (bound by the current value of the `size' parameter). +%% Instances shrink towards `0'. +-spec int() -> proper_types:type(). +int() -> ?SIZED(Size, integer(-Size,Size)). + +%% @doc Small non-negative integers (bound by the current value of the `size' +%% parameter). Instances shrink towards `0'. +-spec nat() -> proper_types:type(). +nat() -> ?SIZED(Size, integer(0,Size)). + +%% @equiv integer() +-spec largeint() -> proper_types:type(). +largeint() -> integer(). + +%% @equiv float() +-spec real() -> proper_types:type(). +real() -> float(). + +%% @equiv boolean() +-spec bool() -> proper_types:type(). +bool() -> boolean(). + +%% @equiv integer(Low, High) +-spec choose(extint(), extint()) -> proper_types:type(). +choose(Low, High) -> integer(Low, High). + +%% @equiv union(Choices) +-spec elements([raw_type(),...]) -> proper_types:type(). +elements(Choices) -> union(Choices). + +%% @equiv union(Choices) +-spec oneof([raw_type(),...]) -> proper_types:type(). +oneof(Choices) -> union(Choices). + +%% @equiv weighted_union(Choices) +-spec frequency([{frequency(),raw_type()},...]) -> proper_types:type(). +frequency(FreqChoices) -> weighted_union(FreqChoices). + +%% @equiv exactly(E) +-spec return(term()) -> proper_types:type(). +return(E) -> exactly(E). + +%% @doc Adds a default value, `Default', to `Type'. +%% The default serves as a primary shrinking target for instances, while it +%% is also chosen by the random instance generation subsystem half the time. +-spec default(raw_type(), raw_type()) -> proper_types:type(). +default(Default, Type) -> + union([Default, Type]). + +%% @doc All sorted lists containing elements of type `ElemType'. +%% Instances shrink towards the empty list, `[]'. +-spec orderedlist(ElemType::raw_type()) -> proper_types:type(). +orderedlist(RawElemType) -> + ?LET(L, list(RawElemType), lists:sort(L)). + +%% @equiv function(0, RetType) +-spec function0(raw_type()) -> proper_types:type(). +function0(RetType) -> + function(0, RetType). + +%% @equiv function(1, RetType) +-spec function1(raw_type()) -> proper_types:type(). +function1(RetType) -> + function(1, RetType). + +%% @equiv function(2, RetType) +-spec function2(raw_type()) -> proper_types:type(). +function2(RetType) -> + function(2, RetType). + +%% @equiv function(3, RetType) +-spec function3(raw_type()) -> proper_types:type(). +function3(RetType) -> + function(3, RetType). + +%% @equiv function(4, RetType) +-spec function4(raw_type()) -> proper_types:type(). +function4(RetType) -> + function(4, RetType). + +%% @doc A specialization of {@link default/2}, where `Default' and `Type' are +%% assigned weights to be considered by the random instance generator. The +%% shrinking subsystem will ignore the weights and try to shrink using the +%% default value. +-spec weighted_default({frequency(),raw_type()}, {frequency(),raw_type()}) -> + proper_types:type(). +weighted_default(Default, Type) -> + weighted_union([Default, Type]). + + +%%------------------------------------------------------------------------------ +%% Additional type specification functions +%%------------------------------------------------------------------------------ + +%% @doc Overrides the `size' parameter used when generating instances of +%% `Type' with `NewSize'. Has no effect on size-less types, such as unions. +%% Also, this will not affect the generation of any internal types contained in +%% `Type', such as the elements of a list - those will still be generated +%% using the test-wide value of `size'. One use of this function is to modify +%% types to produce instances that grow faster or slower, like so: +%% ```?SIZED(Size, resize(Size * 2, list(integer()))''' +%% The above specifies a list type that grows twice as fast as normal lists. +-spec resize(size(), Type::raw_type()) -> proper_types:type(). +resize(NewSize, RawType) -> + Type = cook_outer(RawType), + case find_prop(size_transform, Type) of + {ok,Transform} -> + add_prop(size_transform, fun(_S) -> Transform(NewSize) end, Type); + error -> + add_prop(size_transform, fun(_S) -> NewSize end, Type) + end. + +%% @doc This is a predefined constraint that can be applied to random-length +%% list and binary types to ensure that the produced values are never empty. +%% +%% e.g. {@link list/0}, {@link string/0}, {@link binary/0}) +-spec non_empty(ListType::raw_type()) -> proper_types:type(). +non_empty(RawListType) -> + ?SUCHTHAT(L, RawListType, L =/= [] andalso L =/= <<>>). + +%% @doc Creates a new type which is equivalent to `Type', but whose instances +%% are never shrunk by the shrinking subsystem. +-spec noshrink(Type::raw_type()) -> proper_types:type(). +noshrink(RawType) -> + add_prop(noshrink, true, cook_outer(RawType)). + +%% @doc Associates the atom key `Parameter' with the value `Value' while +%% generating instances of `Type'. +-spec with_parameter(atom(), value(), Type::raw_type()) -> proper_types:type(). +with_parameter(Parameter, Value, RawType) -> + with_parameters([{Parameter,Value}], RawType). + +%% @doc Similar to {@link with_parameter/3}, but accepts a list of +%% `{Parameter, Value}' pairs. +-spec with_parameters([{atom(),value()}], Type::raw_type()) -> + proper_types:type(). +with_parameters(PVlist, RawType) -> + Type = cook_outer(RawType), + case find_prop(parameters, Type) of + {ok,Params} when is_list(Params) -> + append_list_to_prop(parameters, PVlist, Type); + error -> + add_prop(parameters, PVlist, Type) + end. + +%% @doc Returns the value associated with `Parameter', or `Default' in case +%% `Parameter' is not associated with any value. +-spec parameter(atom(), value()) -> value(). +parameter(Parameter, Default) -> + Parameters = + case erlang:get('$parameters') of + undefined -> []; + List -> List + end, + proplists:get_value(Parameter, Parameters, Default). + +%% @equiv parameter(Parameter, undefined) +-spec parameter(atom()) -> value(). +parameter(Parameter) -> + parameter(Parameter, undefined). diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_typeserver.erl b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_typeserver.erl new file mode 100644 index 0000000000..b16075763f --- /dev/null +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_typeserver.erl @@ -0,0 +1,2411 @@ +%%% Copyright 2010-2016 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2016 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis + +%%% @doc Erlang type system - PropEr type system integration module. +%%% +%%% PropEr can parse types expressed in Erlang's type language and convert them +%%% to its own type format. Such expressions can be used instead of regular type +%%% constructors in the second argument of `?FORALL's. No extra notation is +%%% required; PropEr will detect which calls correspond to native types by +%%% applying a parse transform during compilation. This parse transform is +%%% automatically applied to any module that includes the `proper.hrl' header +%%% file. You can disable this feature by compiling your modules with +%%% `-DPROPER_NO_TRANS'. Note that this will currently also disable the +%%% automatic exporting of properties. +%%% +%%% The use of native types in properties is subject to the following usage +%%% rules: +%%% <ul> +%%% <li>Native types cannot be used outside of `?FORALL's.</li> +%%% <li>Inside `?FORALL's, native types can be combined with other native +%%% types, and even with PropEr types, inside tuples and lists (the constructs +%%% `[...]', `{...}' and `++' are all allowed).</li> +%%% <li>All other constructs of Erlang's built-in type system (e.g. `|' for +%%% union, `_' as an alias of `any()', `<<_:_>>' binary type syntax and +%%% `fun((...) -> ...)' function type syntax) are not allowed in `?FORALL's, +%%% because they are rejected by the Erlang parser.</li> +%%% <li>Anything other than a tuple constructor, list constructor, `++' +%%% application, local or remote call will automatically be considered a +%%% PropEr type constructor and not be processed further by the parse +%%% transform.</li> +%%% <li>Parametric native types are fully supported; of course, they can only +%%% appear instantiated in a `?FORALL'. The arguments of parametric native +%%% types are always interpreted as native types.</li> +%%% <li>Parametric PropEr types, on the other hand, can take any kind of +%%% argument. You can even mix native and PropEr types in the arguments of a +%%% PropEr type. For example, assuming that the following declarations are +%%% present: +%%% ``` my_proper_type() -> ?LET(...). +%%% -type my_native_type() :: ... .''' +%%% Then the following expressions are all legal: +%%% ``` vector(2, my_native_type()) +%%% function(0, my_native_type()) +%%% union([my_proper_type(), my_native_type()])''' </li> +%%% <li>Some type constructors can take native types as arguments (but only +%%% inside `?FORALL's): +%%% <ul> +%%% <li>`?SUCHTHAT', `?SUCHTHATMAYBE', `non_empty', `noshrink': these work +%%% with native types too</li> +%%% <li>`?LAZY', `?SHRINK', `resize', `?SIZED': these don't work with native +%%% types</li> +%%% <li>`?LET', `?LETSHRINK': only the top-level base type can be a native +%%% type</li> +%%% </ul></li> +%%% <li>Native type declarations in the `?FORALL's of a module can reference any +%%% custom type declared in a `-type' or `-opaque' attribute of the same +%%% module, as long as no module identifier is used.</li> +%%% <li>Typed records cannot be referenced inside `?FORALL's using the +%%% `#rec_name{}' syntax. To use a typed record in a `?FORALL', enclose the +%%% record in a custom type like so: +%%% ``` -type rec_name() :: #rec_name{}. ''' +%%% and use the custom type instead.</li> +%%% <li>`?FORALL's may contain references to self-recursive or mutually +%%% recursive native types, so long as each type in the hierarchy has a clear +%%% base case. +%%% Currently, PropEr requires that the toplevel of any recursive type +%%% declaration is either a (maybe empty) list or a union containing at least +%%% one choice that doesn't reference the type directly (it may, however, +%%% reference any of the types that are mutually recursive with it). This +%%% means, for example, that some valid recursive type declarations, such as +%%% this one: +%%% ``` ?FORALL(..., a(), ...) ''' +%%% where: +%%% ``` -type a() :: {'a','none' | a()}. ''' +%%% are not accepted by PropEr. However, such types can be rewritten in a way +%%% that allows PropEr to parse them: +%%% ``` ?FORALL(..., a(), ...) ''' +%%% where: +%%% ``` -type a() :: {'a','none'} | {'a',a()}. ''' +%%% This also means that recursive record declarations are not allowed: +%%% ``` ?FORALL(..., rec(), ...) ''' +%%% where: +%%% ``` -type rec() :: #rec{}. +%%% -record(rec, {a = 0 :: integer(), b = 'nil' :: 'nil' | #rec{}}). ''' +%%% A little rewritting can usually remedy this problem as well: +%%% ``` ?FORALL(..., rec(), ...) ''' +%%% where: +%%% ``` -type rec() :: #rec{b :: 'nil'} | #rec{b :: rec()}. +%%% -record(rec, {a = 0 :: integer(), b = 'nil' :: 'nil' | #rec{}}). ''' +%%% </li> +%%% <li>Remote types may be referenced in a `?FORALL', so long as they are +%%% exported from the remote module. Currently, PropEr requires that any +%%% remote modules whose types are directly referenced from within properties +%%% are present in the code path at compile time, either compiled with +%%% `debug_info' enabled or in source form. If PropEr cannot find a remote +%%% module at all, finds only a compiled object file with no debug +%%% information or fails to compile the source file, all calls to that module +%%% will automatically be considered calls to PropEr type constructors.</li> +%%% <li>For native types to be translated correctly, both the module that +%%% contains the `?FORALL' declaration as well as any module that contains +%%% the declaration of a type referenced (directly or indirectly) from inside +%%% a `?FORALL' must be present in the code path at runtime, either compiled +%%% with `debug_info' enabled or in source form.</li> +%%% <li>Local types with the same name as an auto-imported BIF are not accepted +%%% by PropEr, unless the BIF in question has been declared in a +%%% `no_auto_import' option.</li> +%%% <li>When an expression can be interpreted both as a PropEr type and as a +%%% native type, the former takes precedence. This means that a function +%%% `foo()' will shadow a type `foo()' if they are both present in the module. +%%% The same rule applies to remote functions and types as well.</li> +%%% <li>The above may cause some confusion when list syntax is used: +%%% <ul> +%%% <li>The expression `[integer()]' can be interpreted both ways, so the +%%% PropEr way applies. Therefore, instances of this type will always be +%%% lists of length 1, not arbitrary integer lists, as would be expected +%%% when interpreting the expression as a native type.</li> +%%% <li>Assuming that a custom type foo/1 has been declared, the expression +%%% `foo([integer()])' can only be interpreted as a native type declaration, +%%% which means that the generic type of integer lists will be passed to +%%% `foo/1'.</li> +%%% </ul></li> +%%% <li>Currently, PropEr does not detect the following mistakes: +%%% <ul> +%%% <li>inline record-field specializations that reference non-existent +%%% fields</li> +%%% <li>type parameters that are not present in the RHS of a `-type' +%%% declaration</li> +%%% <li>using `_' as a type variable in the LHS of a `-type' declaration</li> +%%% <li>using the same variable in more than one position in the LHS of a +%%% `-type' declaration</li> +%%% </ul> +%%% </li> +%%% </ul> +%%% +%%% You can use <a href="#index">these</a> functions to try out the type +%%% translation subsystem. +%%% +%%% CAUTION: These functions should never be used inside properties. They are +%%% meant for demonstration purposes only. + +-module(proper_typeserver). +-behaviour(gen_server). +-export([demo_translate_type/2, demo_is_instance/3]). + +-export([start/0, restart/0, stop/0, create_spec_test/3, get_exp_specced/1, + is_instance/3, translate_type/1]). +-export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, + code_change/3]). +-export([get_exp_info/1, match/2]). + +-export_type([imm_type/0, mod_exp_types/0, mod_exp_funs/0]). + +-include("proper_internal.hrl"). + + +%%------------------------------------------------------------------------------ +%% Macros +%%------------------------------------------------------------------------------ + +-define(SRC_FILE_EXT, ".erl"). + +-ifdef(AT_LEAST_19). +-define(anno(L), erl_anno:new(L)). +-else. +-define(anno(L), L). +-endif. + +%% Starting with 18.0 we need to handle both 'type' and 'user_type' tags; +%% prior Erlang/OTP releases had only 'type' as a tag. +-define(IS_TYPE_TAG(T), (T =:= type orelse T =:= user_type)). + +%% CAUTION: all these must be sorted +-define(STD_TYPES_0, + [any,arity,atom,binary,bitstring,bool,boolean,byte,char,float,integer, + list,neg_integer,non_neg_integer,number,pos_integer,string,term, + timeout]). +-define(HARD_ADTS, + %% gb_trees:iterator and gb_sets:iterator are NOT hardcoded + [{{array,0},array}, {{array,1},proper_array}, + {{dict,0},dict}, {{dict,2},proper_dict}, + {{gb_set,0},gb_sets}, {{gb_set,1},proper_gb_sets}, + {{gb_tree,0},gb_trees}, {{gb_tree,2},proper_gb_trees}, + {{orddict,2},proper_orddict}, + {{ordset,1},proper_ordsets}, + {{queue,0},queue}, {{queue,1},proper_queue}, + {{set,0},sets}, {{set,1},proper_sets}]). +-define(HARD_ADT_MODS, + [{array, [{{array,0}, + {{type,0,record,[{atom,0,array}]},[]}}]}, + {dict, [{{dict,0}, + {{type,0,record,[{atom,0,dict}]},[]}}]}, + {gb_sets, [{{gb_set,0}, + {{type,0,tuple,[{type,0,non_neg_integer,[]}, + {type,0,gb_set_node,[]}]},[]}}]}, + {gb_trees, [{{gb_tree,0}, + {{type,0,tuple,[{type,0,non_neg_integer,[]}, + {type,0,gb_tree_node,[]}]},[]}}]}, + %% Our parametric ADTs are already declared as normal types, we just + %% need to change them to opaques. + {proper_array, [{{array,1},already_declared}]}, + {proper_dict, [{{dict,2},already_declared}]}, + {proper_gb_sets, [{{gb_set,1},already_declared}, + {{iterator,1},already_declared}]}, + {proper_gb_trees, [{{gb_tree,2},already_declared}, + {{iterator,2},already_declared}]}, + {proper_orddict, [{{orddict,2},already_declared}]}, + {proper_ordsets, [{{ordset,1},already_declared}]}, + {proper_queue, [{{queue,1},already_declared}]}, + {proper_sets, [{{set,1},already_declared}]}, + {queue, [{{queue,0}, + {{type,0,tuple,[{type,0,list,[]},{type,0,list,[]}]},[]}}]}, + {sets, [{{set,0}, + {{type,0,record,[{atom,0,set}]},[]}}]}]). + + +%%------------------------------------------------------------------------------ +%% Types +%%------------------------------------------------------------------------------ + +-type type_name() :: atom(). +-type var_name() :: atom(). %% TODO: also integers? +-type field_name() :: atom(). + +-type type_kind() :: 'type' | 'record'. +-type type_ref() :: {type_kind(),type_name(),arity()}. +-ifdef(NO_MODULES_IN_OPAQUES). +-type substs_dict() :: dict(). %% dict(field_name(),ret_type()) +-else. +-type substs_dict() :: dict:dict(field_name(),ret_type()). +-endif. +-type full_type_ref() :: {mod_name(),type_kind(),type_name(), + [ret_type()] | substs_dict()}. +-type symb_info() :: 'not_symb' | {'orig_abs',abs_type()}. +-type type_repr() :: {'abs_type',abs_type(),[var_name()],symb_info()} + | {'cached',fin_type(),abs_type(),symb_info()} + | {'abs_record',[{field_name(),abs_type()}]}. +-type gen_fun() :: fun((size()) -> fin_type()). +-type rec_fun() :: fun(([gen_fun()],size()) -> fin_type()). +-type rec_arg() :: {boolean() | {'list',boolean(),rec_fun()},full_type_ref()}. +-type rec_args() :: [rec_arg()]. +-type ret_type() :: {'simple',fin_type()} | {'rec',rec_fun(),rec_args()}. +-type rec_fun_info() :: {pos_integer(),pos_integer(),[arity(),...], + [rec_fun(),...]}. + +-type imm_type_ref() :: {type_name(),arity()}. +-type hard_adt_repr() :: {abs_type(),[var_name()]} | 'already_declared'. +-type fun_ref() :: {fun_name(),arity()}. +-type fun_repr() :: fun_clause_repr(). +-type fun_clause_repr() :: {[abs_type()],abs_type()}. +-type proc_fun_ref() :: {fun_name(),[abs_type()],abs_type()}. +-type full_imm_type_ref() :: {mod_name(),type_name(),arity()}. +-type imm_stack() :: [full_imm_type_ref()]. +-type pat_field() :: 0 | 1 | atom(). +-type pattern() :: loose_tuple(pat_field()). +-type next_step() :: 'none' | 'take_head' | {'match_with',pattern()}. + +-ifdef(NO_MODULES_IN_OPAQUES). +%% @private_type +-type mod_exp_types() :: set(). %% set(imm_type_ref()) +-type mod_types() :: dict(). %% dict(type_ref(),type_repr()) +%% @private_type +-type mod_exp_funs() :: set(). %% set(fun_ref()) +-type mod_specs() :: dict(). %% dict(fun_ref(),fun_repr()) +-else. +%% @private_type +-type mod_exp_types() :: sets:set(imm_type_ref()). +-type mod_types() :: dict:dict(type_ref(),type_repr()). +%% @private_type +-type mod_exp_funs() :: sets:set(fun_ref()). +-type mod_specs() :: dict:dict(fun_ref(),fun_repr()). +-endif. + +-ifdef(NO_MODULES_IN_OPAQUES). +-record(state, + {cached = dict:new() :: dict(), %% dict(imm_type(),fin_type()) + exp_types = dict:new() :: dict(), %% dict(mod_name(),mod_exp_types()) + types = dict:new() :: dict(), %% dict(mod_name(),mod_types()) + exp_specs = dict:new() :: dict()}). %% dict(mod_name(),mod_specs()) +-else. +-record(state, + {cached = dict:new() :: dict:dict(imm_type(),fin_type()), + exp_types = dict:new() :: dict:dict(mod_name(),mod_exp_types()), + types = dict:new() :: dict:dict(mod_name(),mod_types()), + exp_specs = dict:new() :: dict:dict(mod_name(),mod_specs())}). +-endif. +-type state() :: #state{}. + +-record(mod_info, + {mod_exp_types = sets:new() :: mod_exp_types(), + mod_types = dict:new() :: mod_types(), + mod_opaques = sets:new() :: mod_exp_types(), + mod_exp_funs = sets:new() :: mod_exp_funs(), + mod_specs = dict:new() :: mod_specs()}). +-type mod_info() :: #mod_info{}. + +-type stack() :: [full_type_ref() | 'tuple' | 'list' | 'union' | 'fun']. +-ifdef(NO_MODULES_IN_OPAQUES). +-type var_dict() :: dict(). %% dict(var_name(),ret_type()) +-else. +-type var_dict() :: dict:dict(var_name(),ret_type()). +-endif. +%% @private_type +-type imm_type() :: {mod_name(),string()}. +%% @alias +-type fin_type() :: proper_types:type(). +-type tagged_result(T) :: {'ok',T} | 'error'. +-type tagged_result2(T,S) :: {'ok',T,S} | 'error'. +%% @alias +-type rich_result(T) :: {'ok',T} | {'error',term()}. +-type rich_result2(T,S) :: {'ok',T,S} | {'error',term()}. +-type false_positive_mfas() :: proper:false_positive_mfas(). + +-type server_call() :: {'create_spec_test',mfa(),timeout(),false_positive_mfas()} + | {'get_exp_specced',mod_name()} + | {'get_type_repr',mod_name(),type_ref(),boolean()} + | {'translate_type',imm_type()}. +-type server_response() :: rich_result(proper:test()) + | rich_result([mfa()]) + | rich_result(type_repr()) + | rich_result(fin_type()). + + +%%------------------------------------------------------------------------------ +%% Server interface functions +%%------------------------------------------------------------------------------ + +%% @private +-spec start() -> 'ok'. +start() -> + {ok,TypeserverPid} = gen_server:start_link(?MODULE, dummy, []), + put('$typeserver_pid', TypeserverPid), + ok. + +%% @private +-spec restart() -> 'ok'. +restart() -> + TypeserverPid = get('$typeserver_pid'), + case (TypeserverPid =:= undefined orelse not is_process_alive(TypeserverPid)) of + true -> start(); + false -> ok + end. + +%% @private +-spec stop() -> 'ok'. +stop() -> + TypeserverPid = get('$typeserver_pid'), + erase('$typeserver_pid'), + gen_server:cast(TypeserverPid, stop). + +%% @private +-spec create_spec_test(mfa(), timeout(), false_positive_mfas()) -> rich_result(proper:test()). +create_spec_test(MFA, SpecTimeout, FalsePositiveMFAs) -> + TypeserverPid = get('$typeserver_pid'), + gen_server:call(TypeserverPid, {create_spec_test,MFA,SpecTimeout,FalsePositiveMFAs}). + +%% @private +-spec get_exp_specced(mod_name()) -> rich_result([mfa()]). +get_exp_specced(Mod) -> + TypeserverPid = get('$typeserver_pid'), + gen_server:call(TypeserverPid, {get_exp_specced,Mod}). + +-spec get_type_repr(mod_name(), type_ref(), boolean()) -> + rich_result(type_repr()). +get_type_repr(Mod, TypeRef, IsRemote) -> + TypeserverPid = get('$typeserver_pid'), + gen_server:call(TypeserverPid, {get_type_repr,Mod,TypeRef,IsRemote}). + +%% @private +-spec translate_type(imm_type()) -> rich_result(fin_type()). +translate_type(ImmType) -> + TypeserverPid = get('$typeserver_pid'), + gen_server:call(TypeserverPid, {translate_type,ImmType}). + +%% @doc Translates the native type expression `TypeExpr' (which should be +%% provided inside a string) into a PropEr type, which can then be passed to any +%% of the demo functions defined in the {@link proper_gen} module. PropEr acts +%% as if it found this type expression inside the code of module `Mod'. +-spec demo_translate_type(mod_name(), string()) -> rich_result(fin_type()). +demo_translate_type(Mod, TypeExpr) -> + start(), + Result = translate_type({Mod,TypeExpr}), + stop(), + Result. + +%% @doc Checks if `Term' is a valid instance of native type `TypeExpr' (which +%% should be provided inside a string). PropEr acts as if it found this type +%% expression inside the code of module `Mod'. +-spec demo_is_instance(term(), mod_name(), string()) -> + boolean() | {'error',term()}. +demo_is_instance(Term, Mod, TypeExpr) -> + case parse_type(TypeExpr) of + {ok,TypeForm} -> + start(), + Result = + %% Force the typeserver to load the module. + case translate_type({Mod,"integer()"}) of + {ok,_FinType} -> + try is_instance(Term, Mod, TypeForm) + catch + throw:{'$typeserver',Reason} -> {error, Reason} + end; + {error,_Reason} = Error -> + Error + end, + stop(), + Result; + {error,_Reason} = Error -> + Error + end. + + +%%------------------------------------------------------------------------------ +%% Implementation of gen_server interface +%%------------------------------------------------------------------------------ + +%% @private +-spec init(_) -> {'ok',state()}. +init(_) -> + {ok, #state{}}. + +%% @private +-spec handle_call(server_call(), _, state()) -> + {'reply',server_response(),state()}. +handle_call({create_spec_test,MFA,SpecTimeout,FalsePositiveMFAs}, _From, State) -> + case create_spec_test(MFA, SpecTimeout, FalsePositiveMFAs, State) of + {ok,Test,NewState} -> + {reply, {ok,Test}, NewState}; + {error,_Reason} = Error -> + {reply, Error, State} + end; +handle_call({get_exp_specced,Mod}, _From, State) -> + case get_exp_specced(Mod, State) of + {ok,MFAs,NewState} -> + {reply, {ok,MFAs}, NewState}; + {error,_Reason} = Error -> + {reply, Error, State} + end; +handle_call({get_type_repr,Mod,TypeRef,IsRemote}, _From, State) -> + case get_type_repr(Mod, TypeRef, IsRemote, State) of + {ok,TypeRepr,NewState} -> + {reply, {ok,TypeRepr}, NewState}; + {error,_Reason} = Error -> + {reply, Error, State} + end; +handle_call({translate_type,ImmType}, _From, State) -> + case translate_type(ImmType, State) of + {ok,FinType,NewState} -> + {reply, {ok,FinType}, NewState}; + {error,_Reason} = Error -> + {reply, Error, State} + end. + +%% @private +-spec handle_cast('stop', state()) -> {'stop','normal',state()}. +handle_cast(stop, State) -> + {stop, normal, State}. + +%% @private +-spec handle_info(term(), state()) -> {'stop',{'received_info',term()},state()}. +handle_info(Info, State) -> + {stop, {received_info,Info}, State}. + +%% @private +-spec terminate(term(), state()) -> 'ok'. +terminate(_Reason, _State) -> + ok. + +%% @private +-spec code_change(term(), state(), _) -> {'ok',state()}. +code_change(_OldVsn, State, _) -> + {ok, State}. + + +%%------------------------------------------------------------------------------ +%% Top-level interface +%%------------------------------------------------------------------------------ + +-spec create_spec_test(mfa(), timeout(), false_positive_mfas(), state()) -> + rich_result2(proper:test(),state()). +create_spec_test(MFA, SpecTimeout, FalsePositiveMFAs, State) -> + case get_exp_spec(MFA, State) of + {ok,FunRepr,NewState} -> + make_spec_test(MFA, FunRepr, SpecTimeout, FalsePositiveMFAs, NewState); + {error,_Reason} = Error -> + Error + end. + +-spec get_exp_spec(mfa(), state()) -> rich_result2(fun_repr(),state()). +get_exp_spec({Mod,Fun,Arity} = MFA, State) -> + case add_module(Mod, State) of + {ok,#state{exp_specs = ExpSpecs} = NewState} -> + ModExpSpecs = dict:fetch(Mod, ExpSpecs), + case dict:find({Fun,Arity}, ModExpSpecs) of + {ok,FunRepr} -> + {ok, FunRepr, NewState}; + error -> + {error, {function_not_exported_or_specced,MFA}} + end; + {error,_Reason} = Error -> + Error + end. + +-spec make_spec_test(mfa(), fun_repr(), timeout(), false_positive_mfas(), state()) -> + rich_result2(proper:test(),state()). +make_spec_test({Mod,_Fun,_Arity}=MFA, {Domain,_Range}=FunRepr, SpecTimeout, FalsePositiveMFAs, State) -> + case convert(Mod, {type,?anno(0),'$fixed_list',Domain}, State) of + {ok,FinType,NewState} -> + Test = ?FORALL(Args, FinType, apply_spec_test(MFA, FunRepr, SpecTimeout, FalsePositiveMFAs, Args)), + {ok, Test, NewState}; + {error,_Reason} = Error -> + Error + end. + +-spec apply_spec_test(mfa(), fun_repr(), timeout(), false_positive_mfas(), term()) -> proper:test(). +apply_spec_test({Mod,Fun,_Arity}=MFA, {_Domain,Range}, SpecTimeout, FalsePositiveMFAs, Args) -> + ?TIMEOUT(SpecTimeout, + begin + %% NOTE: only call apply/3 inside try/catch (do not trust ?MODULE:is_instance/3) + Result = + try apply(Mod, Fun, Args) of + X -> {ok, X} + catch + X:Y -> {X, Y} + end, + case Result of + {ok, Z} -> + case ?MODULE:is_instance(Z, Mod, Range) of + true -> + true; + false when is_function(FalsePositiveMFAs) -> + FalsePositiveMFAs(MFA, Args, {fail, Z}); + false -> + false + end; + Exception when is_function(FalsePositiveMFAs) -> + case FalsePositiveMFAs(MFA, Args, Exception) of + true -> + true; + false -> + error(Exception, erlang:get_stacktrace()) + end; + Exception -> + error(Exception, erlang:get_stacktrace()) + end + end). + +-spec get_exp_specced(mod_name(), state()) -> rich_result2([mfa()],state()). +get_exp_specced(Mod, State) -> + case add_module(Mod, State) of + {ok,#state{exp_specs = ExpSpecs} = NewState} -> + ModExpSpecs = dict:fetch(Mod, ExpSpecs), + ExpSpecced = [{Mod,F,A} || {F,A} <- dict:fetch_keys(ModExpSpecs)], + {ok, ExpSpecced, NewState}; + {error,_Reason} = Error -> + Error + end. + +-spec get_type_repr(mod_name(), type_ref(), boolean(), state()) -> + rich_result2(type_repr(),state()). +get_type_repr(Mod, {type,Name,Arity} = TypeRef, true, State) -> + case prepare_for_remote(Mod, Name, Arity, State) of + {ok,NewState} -> + get_type_repr(Mod, TypeRef, false, NewState); + {error,_Reason} = Error -> + Error + end; +get_type_repr(Mod, TypeRef, false, #state{types = Types} = State) -> + ModTypes = dict:fetch(Mod, Types), + case dict:find(TypeRef, ModTypes) of + {ok,TypeRepr} -> + {ok, TypeRepr, State}; + error -> + {error, {missing_type,Mod,TypeRef}} + end. + +-spec prepare_for_remote(mod_name(), type_name(), arity(), state()) -> + rich_result(state()). +prepare_for_remote(RemMod, Name, Arity, State) -> + case add_module(RemMod, State) of + {ok,#state{exp_types = ExpTypes} = NewState} -> + RemModExpTypes = dict:fetch(RemMod, ExpTypes), + case sets:is_element({Name,Arity}, RemModExpTypes) of + true -> {ok, NewState}; + false -> {error, {type_not_exported,{RemMod,Name,Arity}}} + end; + {error,_Reason} = Error -> + Error + end. + +-spec translate_type(imm_type(), state()) -> rich_result2(fin_type(),state()). +translate_type({Mod,Str} = ImmType, #state{cached = Cached} = State) -> + case dict:find(ImmType, Cached) of + {ok,Type} -> + {ok, Type, State}; + error -> + case parse_type(Str) of + {ok,TypeForm} -> + case add_module(Mod, State) of + {ok,NewState} -> + case convert(Mod, TypeForm, NewState) of + {ok,FinType, + #state{cached = Cached} = FinalState} -> + NewCached = dict:store(ImmType, FinType, + Cached), + {ok, FinType, + FinalState#state{cached = NewCached}}; + {error,_Reason} = Error -> + Error + end; + {error,_Reason} = Error -> + Error + end; + {error,Reason} -> + {error, {parse_error,Str,Reason}} + end + end. + +-spec parse_type(string()) -> rich_result(abs_type()). +parse_type(Str) -> + TypeStr = "-type mytype() :: " ++ Str ++ ".", + case erl_scan:string(TypeStr) of + {ok,Tokens,_EndLocation} -> + case erl_parse:parse_form(Tokens) of + {ok,{attribute,_Line,type,{mytype,TypeExpr,[]}}} -> + {ok, TypeExpr}; + {error,_ErrorInfo} = Error -> + Error + end; + {error,ErrorInfo,_EndLocation} -> + {error, ErrorInfo} + end. + +-spec add_module(mod_name(), state()) -> rich_result(state()). +add_module(Mod, #state{exp_types = ExpTypes} = State) -> + case dict:is_key(Mod, ExpTypes) of + true -> + {ok, State}; + false -> + case get_code_and_exports(Mod) of + {ok,AbsCode,ModExpFuns} -> + RawModInfo = get_mod_info(Mod, AbsCode, ModExpFuns), + ModInfo = process_adts(Mod, RawModInfo), + {ok, store_mod_info(Mod, ModInfo, State)}; + {error,Reason} -> + {error, {cant_load_code,Mod,Reason}} + end + end. + +%% @private +-spec get_exp_info(mod_name()) -> rich_result2(mod_exp_types(),mod_exp_funs()). +get_exp_info(Mod) -> + case get_code_and_exports(Mod) of + {ok,AbsCode,ModExpFuns} -> + RawModInfo = get_mod_info(Mod, AbsCode, ModExpFuns), + {ok, RawModInfo#mod_info.mod_exp_types, ModExpFuns}; + {error,_Reason} = Error -> + Error + end. + +-spec get_code_and_exports(mod_name()) -> + rich_result2([abs_form()],mod_exp_funs()). +get_code_and_exports(Mod) -> + case code:get_object_code(Mod) of + {Mod, ObjBin, _ObjFileName} -> + case get_chunks(ObjBin) of + {ok,_AbsCode,_ModExpFuns} = Result -> + Result; + {error,Reason} -> + get_code_and_exports_from_source(Mod, Reason) + end; + error -> + get_code_and_exports_from_source(Mod, cant_find_object_file) + end. + +-spec get_code_and_exports_from_source(mod_name(), term()) -> + rich_result2([abs_form()],mod_exp_funs()). +get_code_and_exports_from_source(Mod, ObjError) -> + SrcFileName = atom_to_list(Mod) ++ ?SRC_FILE_EXT, + case code:where_is_file(SrcFileName) of + FullSrcFileName when is_list(FullSrcFileName) -> + Opts = [binary,debug_info,return_errors,{d,'PROPER_REMOVE_PROPS'}], + case compile:file(FullSrcFileName, Opts) of + {ok,Mod,Binary} -> + get_chunks(Binary); + {error,Errors,_Warnings} -> + {error, {ObjError,{cant_compile_source_file,Errors}}} + end; + non_existing -> + {error, {ObjError,cant_find_source_file}} + end. + +-spec get_chunks(string() | binary()) -> + rich_result2([abs_form()],mod_exp_funs()). +get_chunks(ObjFile) -> + case beam_lib:chunks(ObjFile, [abstract_code,exports]) of + {ok,{_Mod,[{abstract_code,AbsCodeChunk},{exports,ExpFunsList}]}} -> + case AbsCodeChunk of + {raw_abstract_v1,AbsCode} -> + %% HACK: Add a declaration for iolist() to every module + {ok, add_iolist(AbsCode), sets:from_list(ExpFunsList)}; + no_abstract_code -> + {error, no_abstract_code}; + _ -> + {error, unsupported_abstract_code_format} + end; + {error,beam_lib,Reason} -> + {error, Reason} + end. + +-spec add_iolist([abs_form()]) -> [abs_form()]. +add_iolist(Forms) -> + IOListDef = + {type,0,maybe_improper_list, + [{type,0,union,[{type,0,byte,[]},{type,0,binary,[]}, + {type,0,iolist,[]}]}, + {type,0,binary,[]}]}, + IOListDecl = {attribute,0,type,{iolist,IOListDef,[]}}, + [IOListDecl | Forms]. + +-spec get_mod_info(mod_name(), [abs_form()], mod_exp_funs()) -> mod_info(). +get_mod_info(Mod, AbsCode, ModExpFuns) -> + StartModInfo = #mod_info{mod_exp_funs = ModExpFuns}, + ImmModInfo = lists:foldl(fun add_mod_info/2, StartModInfo, AbsCode), + #mod_info{mod_specs = AllModSpecs} = ImmModInfo, + IsExported = fun(FunRef,_FunRepr) -> sets:is_element(FunRef,ModExpFuns) end, + ModExpSpecs = dict:filter(IsExported, AllModSpecs), + ModInfo = ImmModInfo#mod_info{mod_specs = ModExpSpecs}, + case orddict:find(Mod, ?HARD_ADT_MODS) of + {ok,ModADTs} -> + #mod_info{mod_exp_types = ModExpTypes, mod_types = ModTypes, + mod_opaques = ModOpaques} = ModInfo, + ModADTsSet = + sets:from_list([ImmTypeRef + || {ImmTypeRef,_HardADTRepr} <- ModADTs]), + NewModExpTypes = sets:union(ModExpTypes, ModADTsSet), + NewModTypes = lists:foldl(fun store_hard_adt/2, ModTypes, ModADTs), + NewModOpaques = sets:union(ModOpaques, ModADTsSet), + ModInfo#mod_info{mod_exp_types = NewModExpTypes, + mod_types = NewModTypes, + mod_opaques = NewModOpaques}; + error -> + ModInfo + end. + +-spec store_hard_adt({imm_type_ref(),hard_adt_repr()}, mod_types()) -> + mod_types(). +store_hard_adt({_ImmTypeRef,already_declared}, ModTypes) -> + ModTypes; +store_hard_adt({{Name,Arity},{TypeForm,VarNames}}, ModTypes) -> + TypeRef = {type,Name,Arity}, + TypeRepr = {abs_type,TypeForm,VarNames,not_symb}, + dict:store(TypeRef, TypeRepr, ModTypes). + +-spec add_mod_info(abs_form(), mod_info()) -> mod_info(). +add_mod_info({attribute,_Line,export_type,TypesList}, + #mod_info{mod_exp_types = ModExpTypes} = ModInfo) -> + NewModExpTypes = sets:union(sets:from_list(TypesList), ModExpTypes), + ModInfo#mod_info{mod_exp_types = NewModExpTypes}; +add_mod_info({attribute,_Line,type,{{record,RecName},Fields,[]}}, + #mod_info{mod_types = ModTypes} = ModInfo) -> + FieldInfo = [process_rec_field(F) || F <- Fields], + NewModTypes = dict:store({record,RecName,0}, {abs_record,FieldInfo}, + ModTypes), + ModInfo#mod_info{mod_types = NewModTypes}; +add_mod_info({attribute,Line,record,{RecName,Fields}}, + #mod_info{mod_types = ModTypes} = ModInfo) -> + case dict:is_key(RecName, ModTypes) of + true -> + ModInfo; + false -> % fake an opaque term by using the same Line as annotation + TypedRecord = {attribute,Line,type,{{record,RecName},Fields,[]}}, + add_mod_info(TypedRecord, ModInfo) + end; +add_mod_info({attribute,_Line,Kind,{Name,TypeForm,VarForms}}, + #mod_info{mod_types = ModTypes, + mod_opaques = ModOpaques} = ModInfo) + when Kind =:= type; Kind =:= opaque -> + Arity = length(VarForms), + VarNames = [V || {var,_,V} <- VarForms], + %% TODO: No check whether variables are different, or non-'_'. + NewModTypes = dict:store({type,Name,Arity}, + {abs_type,TypeForm,VarNames,not_symb}, ModTypes), + NewModOpaques = + case Kind of + type -> ModOpaques; + opaque -> sets:add_element({Name,Arity}, ModOpaques) + end, + ModInfo#mod_info{mod_types = NewModTypes, mod_opaques = NewModOpaques}; +add_mod_info({attribute,_Line,spec,{RawFunRef,[RawFirstClause | _Rest]}}, + #mod_info{mod_specs = ModSpecs} = ModInfo) -> + FunRef = case RawFunRef of + {_Mod,Name,Arity} -> {Name,Arity}; + {_Name,_Arity} = F -> F + end, + %% TODO: We just take the first function clause. + FirstClause = process_fun_clause(RawFirstClause), + NewModSpecs = dict:store(FunRef, FirstClause, ModSpecs), + ModInfo#mod_info{mod_specs = NewModSpecs}; +add_mod_info(_Form, ModInfo) -> + ModInfo. + +-spec process_rec_field(abs_rec_field()) -> {field_name(),abs_type()}. +process_rec_field({record_field,_,{atom,_,FieldName}}) -> + {FieldName, {type,0,any,[]}}; +process_rec_field({record_field,_,{atom,_,FieldName},_Initialization}) -> + {FieldName, {type,0,any,[]}}; +process_rec_field({typed_record_field,RecField,FieldType}) -> + {FieldName,_} = process_rec_field(RecField), + {FieldName, FieldType}. + +-spec process_fun_clause(abs_type()) -> fun_clause_repr(). +process_fun_clause({type,_,'fun',[{type,_,product,Domain},Range]}) -> + {Domain, Range}; +process_fun_clause({type,_,bounded_fun,[MainClause,Constraints]}) -> + {RawDomain,RawRange} = process_fun_clause(MainClause), + VarSubsts = [{V,T} || {type,_,constraint, + [{atom,_,is_subtype},[{var,_,V},T]]} <- Constraints, + V =/= '_'], + VarSubstsDict = dict:from_list(VarSubsts), + Domain = [update_vars(A, VarSubstsDict, false) || A <- RawDomain], + Range = update_vars(RawRange, VarSubstsDict, false), + {Domain, Range}. + +-spec store_mod_info(mod_name(), mod_info(), state()) -> state(). +store_mod_info(Mod, #mod_info{mod_exp_types = ModExpTypes, mod_types = ModTypes, + mod_specs = ImmModExpSpecs}, + #state{exp_types = ExpTypes, types = Types, + exp_specs = ExpSpecs} = State) -> + NewExpTypes = dict:store(Mod, ModExpTypes, ExpTypes), + NewTypes = dict:store(Mod, ModTypes, Types), + ModExpSpecs = dict:map(fun unbound_to_any/2, ImmModExpSpecs), + NewExpSpecs = dict:store(Mod, ModExpSpecs, ExpSpecs), + State#state{exp_types = NewExpTypes, types = NewTypes, + exp_specs = NewExpSpecs}. + +-spec unbound_to_any(fun_ref(), fun_repr()) -> fun_repr(). +unbound_to_any(_FunRef, {Domain,Range}) -> + EmptySubstsDict = dict:new(), + NewDomain = [update_vars(A,EmptySubstsDict,true) || A <- Domain], + NewRange = update_vars(Range, EmptySubstsDict, true), + {NewDomain, NewRange}. + + +%%------------------------------------------------------------------------------ +%% ADT translation functions +%%------------------------------------------------------------------------------ + +-spec process_adts(mod_name(), mod_info()) -> mod_info(). +process_adts(Mod, + #mod_info{mod_exp_types = ModExpTypes, mod_opaques = ModOpaques, + mod_specs = ModExpSpecs} = ModInfo) -> + %% TODO: No warning on unexported opaques. + case sets:to_list(sets:intersection(ModExpTypes,ModOpaques)) of + [] -> + ModInfo; + ModADTs -> + %% TODO: No warning on unexported API functions. + ModExpSpecsList = [{Name,Domain,Range} + || {{Name,_Arity},{Domain,Range}} + <- dict:to_list(ModExpSpecs)], + AddADT = fun(ADT,Acc) -> add_adt(Mod,ADT,Acc,ModExpSpecsList) end, + lists:foldl(AddADT, ModInfo, ModADTs) + end. + +-spec add_adt(mod_name(), imm_type_ref(), mod_info(), [proc_fun_ref()]) -> + mod_info(). +add_adt(Mod, {Name,Arity}, #mod_info{mod_types = ModTypes} = ModInfo, + ModExpFunSpecs) -> + ADTRef = {type,Name,Arity}, + {abs_type,InternalRepr,VarNames,not_symb} = dict:fetch(ADTRef, ModTypes), + FullADTRef = {Mod,Name,Arity}, + %% TODO: No warning on unsuitable range. + SymbCalls1 = [get_symb_call(FullADTRef,Spec) || Spec <- ModExpFunSpecs], + %% TODO: No warning on bad use of variables. + SymbCalls2 = [fix_vars(FullADTRef,Call,RangeVars,VarNames) + || {ok,Call,RangeVars} <- SymbCalls1], + case [Call || {ok,Call} <- SymbCalls2] of + [] -> + %% TODO: No warning on no acceptable spec. + ModInfo; + SymbCalls3 -> + NewADTRepr = {abs_type,{type,0,union,SymbCalls3},VarNames, + {orig_abs,InternalRepr}}, + NewModTypes = dict:store(ADTRef, NewADTRepr, ModTypes), + ModInfo#mod_info{mod_types = NewModTypes} + end. + +-spec get_symb_call(full_imm_type_ref(), proc_fun_ref()) -> + tagged_result2(abs_type(),[var_name()]). +get_symb_call({Mod,_TypeName,_Arity} = FullADTRef, {FunName,Domain,Range}) -> + A = ?anno(0), + BaseCall = {type,A,tuple,[{atom,A,'$call'},{atom,A,Mod},{atom,A,FunName}, + {type,A,'$fixed_list',Domain}]}, + unwrap_range(FullADTRef, BaseCall, Range, false). + +-spec unwrap_range(full_imm_type_ref(), abs_type() | next_step(), abs_type(), + boolean()) -> + tagged_result2(abs_type() | next_step(),[var_name()]). +unwrap_range(FullADTRef, Call, {paren_type,_,[Type]}, TestRun) -> + unwrap_range(FullADTRef, Call, Type, TestRun); +unwrap_range(FullADTRef, Call, {ann_type,_,[_Var,Type]}, TestRun) -> + unwrap_range(FullADTRef, Call, Type, TestRun); +unwrap_range(FullADTRef, Call, {type,_,list,[ElemType]}, TestRun) -> + unwrap_list(FullADTRef, Call, ElemType, TestRun); +unwrap_range(FullADTRef, Call, {type,_,maybe_improper_list,[Cont,_Term]}, + TestRun) -> + unwrap_list(FullADTRef, Call, Cont, TestRun); +unwrap_range(FullADTRef, Call, {type,_,nonempty_list,[ElemType]}, TestRun) -> + unwrap_list(FullADTRef, Call, ElemType, TestRun); +unwrap_range(FullADTRef, Call, {type,_,nonempty_improper_list,[Cont,_Term]}, + TestRun) -> + unwrap_list(FullADTRef, Call, Cont, TestRun); +unwrap_range(FullADTRef, Call, + {type,_,nonempty_maybe_improper_list,[Cont,_Term]}, TestRun) -> + unwrap_list(FullADTRef, Call, Cont, TestRun); +unwrap_range(_FullADTRef, _Call, {type,_,tuple,any}, _TestRun) -> + error; +unwrap_range(FullADTRef, Call, {type,_,tuple,FieldForms}, TestRun) -> + Translates = fun(T) -> unwrap_range(FullADTRef,none,T,true) =/= error end, + case proper_arith:find_first(Translates, FieldForms) of + none -> + error; + {TargetPos,TargetElem} -> + Pattern = get_pattern(TargetPos, FieldForms), + case TestRun of + true -> + NewCall = + case Call of + none -> {match_with,Pattern}; + _ -> Call + end, + {ok, NewCall, []}; + false -> + AbsPattern = term_to_singleton_type(Pattern), + A = ?anno(0), + NewCall = + {type,A,tuple, + [{atom,A,'$call'},{atom,A,?MODULE},{atom,A,match}, + {type,A,'$fixed_list',[AbsPattern,Call]}]}, + unwrap_range(FullADTRef, NewCall, TargetElem, TestRun) + end + end; +unwrap_range(FullADTRef, Call, {type,_,union,Choices}, TestRun) -> + TestedChoices = [unwrap_range(FullADTRef,none,C,true) || C <- Choices], + NotError = fun(error) -> false; (_) -> true end, + case proper_arith:find_first(NotError, TestedChoices) of + none -> + error; + {_ChoicePos,{ok,none,_RangeVars}} -> + error; + {ChoicePos,{ok,NextStep,_RangeVars}} -> + {A, [ChoiceElem|B]} = lists:split(ChoicePos-1, Choices), + OtherChoices = A ++ B, + DistinctChoice = + case NextStep of + take_head -> + fun cant_have_head/1; + {match_with,Pattern} -> + fun(C) -> cant_match(Pattern, C) end + end, + case {lists:all(DistinctChoice,OtherChoices), TestRun} of + {true,true} -> + {ok, NextStep, []}; + {true,false} -> + unwrap_range(FullADTRef, Call, ChoiceElem, TestRun); + {false,_} -> + error + end + end; +unwrap_range({_Mod,SameName,Arity}, Call, {type,_,SameName,ArgForms}, + _TestRun) -> + RangeVars = [V || {var,_,V} <- ArgForms, V =/= '_'], + case length(ArgForms) =:= Arity andalso length(RangeVars) =:= Arity of + true -> {ok, Call, RangeVars}; + false -> error + end; +unwrap_range({SameMod,SameName,_Arity} = FullADTRef, Call, + {remote_type,_,[{atom,_,SameMod},{atom,_,SameName},ArgForms]}, + TestRun) -> + unwrap_range(FullADTRef, Call, {type,?anno(0),SameName,ArgForms}, TestRun); +unwrap_range(_FullADTRef, _Call, _Range, _TestRun) -> + error. + +-spec unwrap_list(full_imm_type_ref(), abs_type() | next_step(), abs_type(), + boolean()) -> + tagged_result2(abs_type() | next_step(),[var_name()]). +unwrap_list(FullADTRef, Call, HeadType, TestRun) -> + NewCall = + case TestRun of + true -> + case Call of + none -> take_head; + _ -> Call + end; + false -> + {type,0,tuple,[{atom,0,'$call'},{atom,0,erlang},{atom,0,hd}, + {type,0,'$fixed_list',[Call]}]} + end, + unwrap_range(FullADTRef, NewCall, HeadType, TestRun). + +-spec fix_vars(full_imm_type_ref(), abs_type(), [var_name()], [var_name()]) -> + tagged_result(abs_type()). +fix_vars(FullADTRef, Call, RangeVars, VarNames) -> + NotAnyVar = fun(V) -> V =/= '_' end, + case no_duplicates(VarNames) andalso lists:all(NotAnyVar,VarNames) of + true -> + RawUsedVars = + collect_vars(FullADTRef, Call, [[V] || V <- RangeVars]), + UsedVars = [lists:usort(L) || L <- RawUsedVars], + case correct_var_use(UsedVars) of + true -> + PairAll = fun(L,Y) -> [{X,{var,0,Y}} || X <- L] end, + VarSubsts = + lists:flatten(lists:zipwith(PairAll,UsedVars,VarNames)), + VarSubstsDict = dict:from_list(VarSubsts), + {ok, update_vars(Call,VarSubstsDict,true)}; + false -> + error + end; + false -> + error + end. + +-spec no_duplicates(list()) -> boolean(). +no_duplicates(L) -> + length(lists:usort(L)) =:= length(L). + +-spec correct_var_use([[var_name() | 0]]) -> boolean(). +correct_var_use(UsedVars) -> + NoNonVarArgs = fun([0|_]) -> false; (_) -> true end, + lists:all(NoNonVarArgs, UsedVars) + andalso no_duplicates(lists:flatten(UsedVars)). + +-spec collect_vars(full_imm_type_ref(), abs_type(), [[var_name() | 0]]) -> + [[var_name() | 0]]. +collect_vars(FullADTRef, {paren_type,_,[Type]}, UsedVars) -> + collect_vars(FullADTRef, Type, UsedVars); +collect_vars(FullADTRef, {ann_type,_,[_Var,Type]}, UsedVars) -> + collect_vars(FullADTRef, Type, UsedVars); +collect_vars(_FullADTRef, {type,_,tuple,any}, UsedVars) -> + UsedVars; +collect_vars({_Mod,SameName,Arity} = FullADTRef, {type,_,SameName,ArgForms}, + UsedVars) -> + case length(ArgForms) =:= Arity of + true -> + VarArgs = [V || {var,_,V} <- ArgForms, V =/= '_'], + case length(VarArgs) =:= Arity of + true -> + AddToList = fun(X,L) -> [X | L] end, + lists:zipwith(AddToList, VarArgs, UsedVars); + false -> + [[0|L] || L <- UsedVars] + end; + false -> + multi_collect_vars(FullADTRef, ArgForms, UsedVars) + end; +collect_vars(FullADTRef, {type,_,_Name,ArgForms}, UsedVars) -> + multi_collect_vars(FullADTRef, ArgForms, UsedVars); +collect_vars({SameMod,SameName,_Arity} = FullADTRef, + {remote_type,_,[{atom,_,SameMod},{atom,_,SameName},ArgForms]}, + UsedVars) -> + collect_vars(FullADTRef, {type,?anno(0),SameName,ArgForms}, UsedVars); +collect_vars(FullADTRef, {remote_type,_,[_RemModForm,_NameForm,ArgForms]}, + UsedVars) -> + multi_collect_vars(FullADTRef, ArgForms, UsedVars); +collect_vars(_FullADTRef, _Call, UsedVars) -> + UsedVars. + +-spec multi_collect_vars(full_imm_type_ref(), [abs_type()], + [[var_name() | 0]]) -> [[var_name() | 0]]. +multi_collect_vars({_Mod,_Name,Arity} = FullADTRef, Forms, UsedVars) -> + NoUsedVars = lists:duplicate(Arity, []), + MoreUsedVars = [collect_vars(FullADTRef,T,NoUsedVars) || T <- Forms], + CombineVars = fun(L1,L2) -> lists:zipwith(fun erlang:'++'/2, L1, L2) end, + lists:foldl(CombineVars, UsedVars, MoreUsedVars). + +-ifdef(NO_MODULES_IN_OPAQUES). +-type var_substs_dict() :: dict(). +-else. +-type var_substs_dict() :: dict:dict(var_name(),abs_type()). +-endif. +-spec update_vars(abs_type(), var_substs_dict(), boolean()) -> abs_type(). +update_vars({paren_type,Line,[Type]}, VarSubstsDict, UnboundToAny) -> + {paren_type, Line, [update_vars(Type,VarSubstsDict,UnboundToAny)]}; +update_vars({ann_type,Line,[Var,Type]}, VarSubstsDict, UnboundToAny) -> + {ann_type, Line, [Var,update_vars(Type,VarSubstsDict,UnboundToAny)]}; +update_vars({var,Line,VarName} = Call, VarSubstsDict, UnboundToAny) -> + case dict:find(VarName, VarSubstsDict) of + {ok,SubstType} -> + SubstType; + error when UnboundToAny =:= false -> + Call; + error when UnboundToAny =:= true -> + {type,Line,any,[]} + end; +update_vars({remote_type,Line,[RemModForm,NameForm,ArgForms]}, VarSubstsDict, + UnboundToAny) -> + NewArgForms = [update_vars(A,VarSubstsDict,UnboundToAny) || A <- ArgForms], + {remote_type, Line, [RemModForm,NameForm,NewArgForms]}; +update_vars({T,_,tuple,any} = Call, _VarSubstsDict, _UnboundToAny) when ?IS_TYPE_TAG(T) -> + Call; +update_vars({T,Line,Name,ArgForms}, VarSubstsDict, UnboundToAny) when ?IS_TYPE_TAG(T) -> + NewArgForms = [update_vars(A,VarSubstsDict,UnboundToAny) || A <- ArgForms], + {T, Line, Name, NewArgForms}; +update_vars(Call, _VarSubstsDict, _UnboundToAny) -> + Call. + + +%%------------------------------------------------------------------------------ +%% Match-related functions +%%------------------------------------------------------------------------------ + +-spec get_pattern(position(), [abs_type()]) -> pattern(). +get_pattern(TargetPos, FieldForms) -> + {0,RevPattern} = lists:foldl(fun add_field/2, {TargetPos,[]}, FieldForms), + list_to_tuple(lists:reverse(RevPattern)). + +-spec add_field(abs_type(), {non_neg_integer(),[pat_field()]}) -> + {non_neg_integer(),[pat_field(),...]}. +add_field(_Type, {1,Acc}) -> + {0, [1|Acc]}; +add_field({atom,_,Tag}, {Left,Acc}) -> + {erlang:max(0,Left-1), [Tag|Acc]}; +add_field(_Type, {Left,Acc}) -> + {erlang:max(0,Left-1), [0|Acc]}. + +%% @private +-spec match(pattern(), tuple()) -> term(). +match(Pattern, Term) when tuple_size(Pattern) =:= tuple_size(Term) -> + match(tuple_to_list(Pattern), tuple_to_list(Term), none, false); +match(_Pattern, _Term) -> + throw(no_match). + +-spec match([pat_field()], [term()], 'none' | {'ok',T}, boolean()) -> T. +match([], [], {ok,Target}, _TypeMode) -> + Target; +match([0|PatRest], [_|ToMatchRest], Acc, TypeMode) -> + match(PatRest, ToMatchRest, Acc, TypeMode); +match([1|PatRest], [Target|ToMatchRest], none, TypeMode) -> + match(PatRest, ToMatchRest, {ok,Target}, TypeMode); +match([Tag|PatRest], [X|ToMatchRest], Acc, TypeMode) when is_atom(Tag) -> + MatchesTag = + case TypeMode of + true -> can_be_tag(Tag, X); + false -> Tag =:= X + end, + case MatchesTag of + true -> match(PatRest, ToMatchRest, Acc, TypeMode); + false -> throw(no_match) + end. + +%% CAUTION: these must be sorted +-define(NON_ATOM_TYPES, + [arity,binary,bitstring,byte,char,float,'fun',function,integer,iodata, + iolist,list,maybe_improper_list,mfa,neg_integer,nil,no_return, + non_neg_integer,none,nonempty_improper_list,nonempty_list, + nonempty_maybe_improper_list,nonempty_string,number,pid,port, + pos_integer,range,record,reference,string,tuple]). +-define(NON_TUPLE_TYPES, + [arity,atom,binary,bitstring,bool,boolean,byte,char,float,'fun', + function,identifier,integer,iodata,iolist,list,maybe_improper_list, + neg_integer,nil,no_return,node,non_neg_integer,none, + nonempty_improper_list,nonempty_list,nonempty_maybe_improper_list, + nonempty_string,number,pid,port,pos_integer,range,reference,string, + timeout]). +-define(NO_HEAD_TYPES, + [arity,atom,binary,bitstring,bool,boolean,byte,char,float,'fun', + function,identifier,integer,mfa,module,neg_integer,nil,no_return,node, + non_neg_integer,none,number,pid,port,pos_integer,range,record, + reference,timeout,tuple]). + +-spec can_be_tag(atom(), abs_type()) -> boolean(). +can_be_tag(Tag, {ann_type,_,[_Var,Type]}) -> + can_be_tag(Tag, Type); +can_be_tag(Tag, {paren_type,_,[Type]}) -> + can_be_tag(Tag, Type); +can_be_tag(Tag, {atom,_,Atom}) -> + Tag =:= Atom; +can_be_tag(_Tag, {integer,_,_Int}) -> + false; +can_be_tag(_Tag, {op,_,_Op,_Arg}) -> + false; +can_be_tag(_Tag, {op,_,_Op,_Arg1,_Arg2}) -> + false; +can_be_tag(Tag, {type,_,BName,[]}) when BName =:= bool; BName =:= boolean -> + is_boolean(Tag); +can_be_tag(Tag, {type,_,timeout,[]}) -> + Tag =:= infinity; +can_be_tag(Tag, {type,_,union,Choices}) -> + lists:any(fun(C) -> can_be_tag(Tag,C) end, Choices); +can_be_tag(_Tag, {type,_,Name,_Args}) -> + not ordsets:is_element(Name, ?NON_ATOM_TYPES); +can_be_tag(_Tag, _Type) -> + true. + +-spec cant_match(pattern(), abs_type()) -> boolean(). +cant_match(Pattern, {ann_type,_,[_Var,Type]}) -> + cant_match(Pattern, Type); +cant_match(Pattern, {paren_type,_,[Type]}) -> + cant_match(Pattern, Type); +cant_match(_Pattern, {atom,_,_Atom}) -> + true; +cant_match(_Pattern, {integer,_,_Int}) -> + true; +cant_match(_Pattern, {op,_,_Op,_Arg}) -> + true; +cant_match(_Pattern, {op,_,_Op,_Arg1,_Arg2}) -> + true; +cant_match(Pattern, {type,Anno,mfa,[]}) -> + MFA_Ts = [{type,Anno,atom,[]}, {type,Anno,atom,[]}, {type,Anno,arity,[]}], + cant_match(Pattern, {type,Anno,tuple,MFA_Ts}); +cant_match(Pattern, {type,_,union,Choices}) -> + lists:all(fun(C) -> cant_match(Pattern,C) end, Choices); +cant_match(_Pattern, {type,_,tuple,any}) -> + false; +cant_match(Pattern, {type,_,tuple,Fields}) -> + tuple_size(Pattern) =/= length(Fields) orelse + try match(tuple_to_list(Pattern), Fields, none, true) of + _ -> false + catch + throw:no_match -> true + end; +cant_match(_Pattern, {type,_,Name,_Args}) -> + ordsets:is_element(Name, ?NON_TUPLE_TYPES); +cant_match(_Pattern, _Type) -> + false. + +-spec cant_have_head(abs_type()) -> boolean(). +cant_have_head({ann_type,_,[_Var,Type]}) -> + cant_have_head(Type); +cant_have_head({paren_type,_,[Type]}) -> + cant_have_head(Type); +cant_have_head({atom,_,_Atom}) -> + true; +cant_have_head({integer,_,_Int}) -> + true; +cant_have_head({op,_,_Op,_Arg}) -> + true; +cant_have_head({op,_,_Op,_Arg1,_Arg2}) -> + true; +cant_have_head({type,_,union,Choices}) -> + lists:all(fun cant_have_head/1, Choices); +cant_have_head({type,_,Name,_Args}) -> + ordsets:is_element(Name, ?NO_HEAD_TYPES); +cant_have_head(_Type) -> + false. + +%% Only covers atoms, integers and tuples, i.e. those that can be specified +%% through singleton types. +-spec term_to_singleton_type(atom() | integer() + | loose_tuple(atom() | integer())) -> abs_type(). +term_to_singleton_type(Atom) when is_atom(Atom) -> + {atom,?anno(0),Atom}; +term_to_singleton_type(Int) when is_integer(Int), Int >= 0 -> + {integer,?anno(0),Int}; +term_to_singleton_type(Int) when is_integer(Int), Int < 0 -> + A = ?anno(0), + {op,A,'-',{integer,A,-Int}}; +term_to_singleton_type(Tuple) when is_tuple(Tuple) -> + Fields = tuple_to_list(Tuple), + {type,?anno(0),tuple,[term_to_singleton_type(F) || F <- Fields]}. + + +%%------------------------------------------------------------------------------ +%% Instance testing functions +%%------------------------------------------------------------------------------ + +%% CAUTION: this must be sorted +-define(EQUIV_TYPES, + [{arity, {type,0,range,[{integer,0,0},{integer,0,255}]}}, + {bool, {type,0,boolean,[]}}, + {byte, {type,0,range,[{integer,0,0},{integer,0,255}]}}, + {char, {type,0,range,[{integer,0,0},{integer,0,16#10ffff}]}}, + {function, {type,0,'fun',[]}}, + {identifier, {type,0,union,[{type,0,pid,[]},{type,0,port,[]}, + {type,0,reference,[]}]}}, + {iodata, {type,0,union,[{type,0,binary,[]},{type,0,iolist,[]}]}}, + {iolist, {type,0,maybe_improper_list, + [{type,0,union,[{type,0,byte,[]},{type,0,binary,[]}, + {type,0,iolist,[]}]}, + {type,0,binary,[]}]}}, + {list, {type,0,list,[{type,0,any,[]}]}}, + {maybe_improper_list, {type,0,maybe_improper_list,[{type,0,any,[]}, + {type,0,any,[]}]}}, + {mfa, {type,0,tuple,[{type,0,atom,[]},{type,0,atom,[]}, + {type,0,arity,[]}]}}, + {node, {type,0,atom,[]}}, + {nonempty_list, {type,0,nonempty_list,[{type,0,any,[]}]}}, + {nonempty_maybe_improper_list, {type,0,nonempty_maybe_improper_list, + [{type,0,any,[]},{type,0,any,[]}]}}, + {nonempty_string, {type,0,nonempty_list,[{type,0,char,[]}]}}, + {string, {type,0,list,[{type,0,char,[]}]}}, + {term, {type,0,any,[]}}, + {timeout, {type,0,union,[{atom,0,infinity}, + {type,0,non_neg_integer,[]}]}}]). + +%% @private +%% TODO: Most of these functions accept an extended form of abs_type(), namely +%% the addition of a custom wrapper: {'from_mod',mod_name(),...} +-spec is_instance(term(), mod_name(), abs_type()) -> boolean(). +is_instance(X, Mod, TypeForm) -> + is_instance(X, Mod, TypeForm, []). + +-spec is_instance(term(), mod_name(), abs_type(), imm_stack()) -> boolean(). +is_instance(X, _Mod, {from_mod,OrigMod,Type}, Stack) -> + is_instance(X, OrigMod, Type, Stack); +is_instance(_X, _Mod, {var,_,'_'}, _Stack) -> + true; +is_instance(_X, _Mod, {var,_,Name}, _Stack) -> + %% All unconstrained spec vars have been replaced by 'any()' and we always + %% replace the variables on the RHS of types before recursing into them. + %% Provided that '-type' declarations contain no unbound variables, we + %% don't expect to find any non-'_' variables while recursing. + throw({'$typeserver',{unbound_var_in_type_declaration,Name}}); +is_instance(X, Mod, {ann_type,_,[_Var,Type]}, Stack) -> + is_instance(X, Mod, Type, Stack); +is_instance(X, Mod, {paren_type,_,[Type]}, Stack) -> + is_instance(X, Mod, Type, Stack); +is_instance(X, Mod, {remote_type,_,[{atom,_,RemMod},{atom,_,Name},ArgForms]}, + Stack) -> + is_custom_instance(X, Mod, RemMod, Name, ArgForms, true, Stack); +is_instance(SameAtom, _Mod, {atom,_,SameAtom}, _Stack) -> + true; +is_instance(SameInt, _Mod, {integer,_,SameInt}, _Stack) -> + true; +is_instance(X, _Mod, {op,_,_Op,_Arg} = Expr, _Stack) -> + is_int_const(X, Expr); +is_instance(X, _Mod, {op,_,_Op,_Arg1,_Arg2} = Expr, _Stack) -> + is_int_const(X, Expr); +is_instance(_X, _Mod, {type,_,any,[]}, _Stack) -> + true; +is_instance(X, _Mod, {type,_,atom,[]}, _Stack) -> + is_atom(X); +is_instance(X, _Mod, {type,_,binary,[]}, _Stack) -> + is_binary(X); +is_instance(X, _Mod, {type,_,binary,[BaseExpr,UnitExpr]}, _Stack) -> + %% <<_:X,_:_*Y>> means "bitstrings of X + k*Y bits, k >= 0" + case eval_int(BaseExpr) of + {ok,Base} when Base >= 0 -> + case eval_int(UnitExpr) of + {ok,Unit} when Unit >= 0 -> + case is_bitstring(X) of + true -> + BitSizeX = bit_size(X), + case Unit =:= 0 of + true -> + BitSizeX =:= Base; + false -> + BitSizeX >= Base + andalso + (BitSizeX - Base) rem Unit =:= 0 + end; + false -> false + end; + _ -> + abs_expr_error(invalid_unit, UnitExpr) + end; + _ -> + abs_expr_error(invalid_base, BaseExpr) + end; +is_instance(X, _Mod, {type,_,bitstring,[]}, _Stack) -> + is_bitstring(X); +is_instance(X, _Mod, {type,_,boolean,[]}, _Stack) -> + is_boolean(X); +is_instance(X, _Mod, {type,_,float,[]}, _Stack) -> + is_float(X); +is_instance(X, _Mod, {type,_,'fun',[]}, _Stack) -> + is_function(X); +%% TODO: how to check range type? random inputs? special case for 0-arity? +is_instance(X, _Mod, {type,_,'fun',[{type,_,any,[]},_Range]}, _Stack) -> + is_function(X); +is_instance(X, _Mod, {type,_,'fun',[{type,_,product,Domain},_Range]}, _Stack) -> + is_function(X, length(Domain)); +is_instance(X, _Mod, {type,_,integer,[]}, _Stack) -> + is_integer(X); +is_instance(X, Mod, {type,_,list,[Type]}, _Stack) -> + list_test(X, Mod, Type, dummy, true, true, false); +is_instance(X, Mod, {type,_,maybe_improper_list,[Cont,Term]}, _Stack) -> + list_test(X, Mod, Cont, Term, true, true, true); +is_instance(X, _Mod, {type,_,module,[]}, _Stack) -> + is_atom(X) orelse + is_tuple(X) andalso X =/= {} andalso is_atom(element(1,X)); +is_instance([], _Mod, {type,_,nil,[]}, _Stack) -> + true; +is_instance(X, _Mod, {type,_,neg_integer,[]}, _Stack) -> + is_integer(X) andalso X < 0; +is_instance(X, _Mod, {type,_,non_neg_integer,[]}, _Stack) -> + is_integer(X) andalso X >= 0; +is_instance(X, Mod, {type,_,nonempty_list,[Type]}, _Stack) -> + list_test(X, Mod, Type, dummy, false, true, false); +is_instance(X, Mod, {type,_,nonempty_improper_list,[Cont,Term]}, _Stack) -> + list_test(X, Mod, Cont, Term, false, false, true); +is_instance(X, Mod, {type,_,nonempty_maybe_improper_list,[Cont,Term]}, + _Stack) -> + list_test(X, Mod, Cont, Term, false, true, true); +is_instance(X, _Mod, {type,_,number,[]}, _Stack) -> + is_number(X); +is_instance(X, _Mod, {type,_,pid,[]}, _Stack) -> + is_pid(X); +is_instance(X, _Mod, {type,_,port,[]}, _Stack) -> + is_port(X); +is_instance(X, _Mod, {type,_,pos_integer,[]}, _Stack) -> + is_integer(X) andalso X > 0; +is_instance(_X, _Mod, {type,_,product,_Elements}, _Stack) -> + throw({'$typeserver',{internal,product_in_is_instance}}); +is_instance(X, _Mod, {type,_,range,[LowExpr,HighExpr]}, _Stack) -> + case {eval_int(LowExpr),eval_int(HighExpr)} of + {{ok,Low},{ok,High}} when Low =< High -> + X >= Low andalso X =< High; + _ -> + abs_expr_error(invalid_range, LowExpr, HighExpr) + end; +is_instance(X, Mod, {type,_,record,[{atom,_,Name} = NameForm | RawSubsts]}, + Stack) -> + Substs = [{N,T} || {type,_,field_type,[{atom,_,N},T]} <- RawSubsts], + SubstsDict = dict:from_list(Substs), + case get_type_repr(Mod, {record,Name,0}, false) of + {ok,{abs_record,OrigFields}} -> + Fields = [case dict:find(FieldName, SubstsDict) of + {ok,NewFieldType} -> NewFieldType; + error -> OrigFieldType + end + || {FieldName,OrigFieldType} <- OrigFields], + is_instance(X, Mod, {type,?anno(0),tuple,[NameForm|Fields]}, Stack); + {error,Reason} -> + throw({'$typeserver',Reason}) + end; +is_instance(X, _Mod, {type,_,reference,[]}, _Stack) -> + is_reference(X); +is_instance(X, _Mod, {type,_,tuple,any}, _Stack) -> + is_tuple(X); +is_instance(X, Mod, {type,_,tuple,Fields}, _Stack) -> + is_tuple(X) andalso tuple_test(tuple_to_list(X), Mod, Fields); +is_instance(X, Mod, {type,_,union,Choices}, Stack) -> + IsInstance = fun(Choice) -> is_instance(X,Mod,Choice,Stack) end, + lists:any(IsInstance, Choices); +is_instance(X, Mod, {T,_,Name,[]}, Stack) when ?IS_TYPE_TAG(T) -> + case orddict:find(Name, ?EQUIV_TYPES) of + {ok,EquivType} -> + is_instance(X, Mod, EquivType, Stack); + error -> + is_maybe_hard_adt(X, Mod, Name, [], Stack) + end; +is_instance(X, Mod, {T,_,Name,ArgForms}, Stack) when ?IS_TYPE_TAG(T) -> + is_maybe_hard_adt(X, Mod, Name, ArgForms, Stack); +is_instance(_X, _Mod, _Type, _Stack) -> + false. + +-spec is_int_const(term(), abs_expr()) -> boolean(). +is_int_const(X, Expr) -> + case eval_int(Expr) of + {ok,Int} -> + X =:= Int; + error -> + abs_expr_error(invalid_int_const, Expr) + end. + +%% TODO: We implicitly add the '| []' at the termination of maybe_improper_list. +%% TODO: We ignore a '[]' termination in improper_list. +-spec list_test(term(), mod_name(), abs_type(), 'dummy' | abs_type(), boolean(), + boolean(), boolean()) -> boolean(). +list_test(X, Mod, Content, Termination, CanEmpty, CanProper, CanImproper) -> + is_list(X) andalso + list_rec(X, Mod, Content, Termination, CanEmpty, CanProper, CanImproper). + +-spec list_rec(term(), mod_name(), abs_type(), 'dummy' | abs_type(), boolean(), + boolean(), boolean()) -> boolean(). +list_rec([], _Mod, _Content, _Termination, CanEmpty, CanProper, _CanImproper) -> + CanEmpty andalso CanProper; +list_rec([X | Rest], Mod, Content, Termination, _CanEmpty, CanProper, + CanImproper) -> + is_instance(X, Mod, Content, []) andalso + list_rec(Rest, Mod, Content, Termination, true, CanProper, CanImproper); +list_rec(X, Mod, _Content, Termination, _CanEmpty, _CanProper, CanImproper) -> + CanImproper andalso is_instance(X, Mod, Termination, []). + +-spec tuple_test([term()], mod_name(), [abs_type()]) -> boolean(). +tuple_test([], _Mod, []) -> + true; +tuple_test([X | XTail], Mod, [T | TTail]) -> + is_instance(X, Mod, T, []) andalso tuple_test(XTail, Mod, TTail); +tuple_test(_, _Mod, _) -> + false. + +-spec is_maybe_hard_adt(term(), mod_name(), type_name(), [abs_type()], + imm_stack()) -> boolean(). +is_maybe_hard_adt(X, Mod, Name, ArgForms, Stack) -> + case orddict:find({Name,length(ArgForms)}, ?HARD_ADTS) of + {ok,ADTMod} -> + is_custom_instance(X, Mod, ADTMod, Name, ArgForms, true, Stack); + error -> + is_custom_instance(X, Mod, Mod, Name, ArgForms, false, Stack) + end. + +-spec is_custom_instance(term(), mod_name(), mod_name(), type_name(), + [abs_type()], boolean(), imm_stack()) -> boolean(). +is_custom_instance(X, Mod, RemMod, Name, RawArgForms, IsRemote, Stack) -> + ArgForms = case Mod =/= RemMod of + true -> [{from_mod,Mod,A} || A <- RawArgForms]; + false -> RawArgForms + end, + Arity = length(ArgForms), + FullTypeRef = {RemMod,Name,Arity}, + case lists:member(FullTypeRef, Stack) of + true -> + throw({'$typeserver',{self_reference,FullTypeRef}}); + false -> + TypeRef = {type,Name,Arity}, + AbsType = get_abs_type(RemMod, TypeRef, ArgForms, IsRemote), + is_instance(X, RemMod, AbsType, [FullTypeRef|Stack]) + end. + +-spec get_abs_type(mod_name(), type_ref(), [abs_type()], boolean()) -> + abs_type(). +get_abs_type(RemMod, TypeRef, ArgForms, IsRemote) -> + case get_type_repr(RemMod, TypeRef, IsRemote) of + {ok,TypeRepr} -> + {FinalAbsType,SymbInfo,VarNames} = + case TypeRepr of + {cached,_FinType,FAT,SI} -> {FAT,SI,[]}; + {abs_type,FAT,VN,SI} -> {FAT,SI,VN} + end, + AbsType = + case SymbInfo of + not_symb -> FinalAbsType; + {orig_abs,OrigAbsType} -> OrigAbsType + end, + VarSubstsDict = dict:from_list(lists:zip(VarNames,ArgForms)), + update_vars(AbsType, VarSubstsDict, false); + {error,Reason} -> + throw({'$typeserver',Reason}) + end. + +-spec abs_expr_error(atom(), abs_expr()) -> no_return(). +abs_expr_error(ImmReason, Expr) -> + {error,Reason} = expr_error(ImmReason, Expr), + throw({'$typeserver',Reason}). + +-spec abs_expr_error(atom(), abs_expr(), abs_expr()) -> no_return(). +abs_expr_error(ImmReason, Expr1, Expr2) -> + {error,Reason} = expr_error(ImmReason, Expr1, Expr2), + throw({'$typeserver',Reason}). + + +%%------------------------------------------------------------------------------ +%% Type translation functions +%%------------------------------------------------------------------------------ + +-spec convert(mod_name(), abs_type(), state()) -> + rich_result2(fin_type(),state()). +convert(Mod, TypeForm, State) -> + case convert(Mod, TypeForm, State, [], dict:new()) of + {ok,{simple,Type},NewState} -> + {ok, Type, NewState}; + {ok,{rec,_RecFun,_RecArgs},_NewState} -> + {error, {internal,rec_returned_to_toplevel}}; + {error,_Reason} = Error -> + Error + end. + +-spec convert(mod_name(), abs_type(), state(), stack(), var_dict()) -> + rich_result2(ret_type(),state()). +convert(Mod, {paren_type,_,[Type]}, State, Stack, VarDict) -> + convert(Mod, Type, State, Stack, VarDict); +convert(Mod, {ann_type,_,[_Var,Type]}, State, Stack, VarDict) -> + convert(Mod, Type, State, Stack, VarDict); +convert(_Mod, {var,_,'_'}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:any()}, State}; +convert(_Mod, {var,_,VarName}, State, _Stack, VarDict) -> + case dict:find(VarName, VarDict) of + %% TODO: do we need to check if we are at toplevel of a recursive? + {ok,RetType} -> {ok, RetType, State}; + error -> {error, {unbound_var,VarName}} + end; +convert(Mod, {remote_type,_,[{atom,_,RemMod},{atom,_,Name},ArgForms]}, State, + Stack, VarDict) -> + case prepare_for_remote(RemMod, Name, length(ArgForms), State) of + {ok,NewState} -> + convert_custom(Mod,RemMod,Name,ArgForms,NewState,Stack,VarDict); + {error,_Reason} = Error -> + Error + end; +convert(_Mod, {atom,_,Atom}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:exactly(Atom)}, State}; +convert(_Mod, {integer,_,_Int} = IntExpr, State, _Stack, _VarDict) -> + convert_integer(IntExpr, State); +convert(_Mod, {op,_,_Op,_Arg} = OpExpr, State, _Stack, _VarDict) -> + convert_integer(OpExpr, State); +convert(_Mod, {op,_,_Op,_Arg1,_Arg2} = OpExpr, State, _Stack, _VarDict) -> + convert_integer(OpExpr, State); +convert(_Mod, {type,_,binary,[BaseExpr,UnitExpr]}, State, _Stack, _VarDict) -> + %% <<_:X,_:_*Y>> means "bitstrings of X + k*Y bits, k >= 0" + case eval_int(BaseExpr) of + {ok,0} -> + case eval_int(UnitExpr) of + {ok,0} -> {ok, {simple,proper_types:exactly(<<>>)}, State}; + {ok,1} -> {ok, {simple,proper_types:bitstring()}, State}; + {ok,8} -> {ok, {simple,proper_types:binary()}, State}; + {ok,N} when N > 0 -> + Gen = ?LET(L, proper_types:list(proper_types:bitstring(N)), + concat_bitstrings(L)), + {ok, {simple,Gen}, State}; + _ -> expr_error(invalid_unit, UnitExpr) + end; + {ok,Base} when Base > 0 -> + Head = proper_types:bitstring(Base), + case eval_int(UnitExpr) of + {ok,0} -> {ok, {simple,Head}, State}; + {ok,1} -> + Tail = proper_types:bitstring(), + {ok, {simple,concat_binary_gens(Head, Tail)}, State}; + {ok,8} -> + Tail = proper_types:binary(), + {ok, {simple,concat_binary_gens(Head, Tail)}, State}; + {ok,N} when N > 0 -> + Tail = + ?LET(L, proper_types:list(proper_types:bitstring(N)), + concat_bitstrings(L)), + {ok, {simple,concat_binary_gens(Head, Tail)}, State}; + _ -> expr_error(invalid_unit, UnitExpr) + end; + _ -> + expr_error(invalid_base, BaseExpr) + end; +convert(_Mod, {type,_,range,[LowExpr,HighExpr]}, State, _Stack, _VarDict) -> + case {eval_int(LowExpr),eval_int(HighExpr)} of + {{ok,Low},{ok,High}} when Low =< High -> + {ok, {simple,proper_types:integer(Low,High)}, State}; + _ -> + expr_error(invalid_range, LowExpr, HighExpr) + end; +convert(_Mod, {type,_,nil,[]}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:exactly([])}, State}; +convert(Mod, {type,_,list,[ElemForm]}, State, Stack, VarDict) -> + convert_list(Mod, false, ElemForm, State, Stack, VarDict); +convert(Mod, {type,_,nonempty_list,[ElemForm]}, State, Stack, VarDict) -> + convert_list(Mod, true, ElemForm, State, Stack, VarDict); +convert(_Mod, {type,_,nonempty_list,[]}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:non_empty(proper_types:list())}, State}; +convert(_Mod, {type,_,nonempty_string,[]}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:non_empty(proper_types:string())}, State}; +convert(_Mod, {type,_,tuple,any}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:tuple()}, State}; +convert(Mod, {type,_,tuple,ElemForms}, State, Stack, VarDict) -> + convert_tuple(Mod, ElemForms, false, State, Stack, VarDict); +convert(Mod, {type,_,'$fixed_list',ElemForms}, State, Stack, VarDict) -> + convert_tuple(Mod, ElemForms, true, State, Stack, VarDict); +convert(Mod, {type,_,record,[{atom,_,Name}|FieldForms]}, State, Stack, + VarDict) -> + convert_record(Mod, Name, FieldForms, State, Stack, VarDict); +convert(Mod, {type,_,union,ChoiceForms}, State, Stack, VarDict) -> + convert_union(Mod, ChoiceForms, State, Stack, VarDict); +convert(Mod, {type,_,'fun',[{type,_,product,Domain},Range]}, State, Stack, + VarDict) -> + convert_fun(Mod, length(Domain), Range, State, Stack, VarDict); +%% TODO: These types should be replaced with accurate types. +%% TODO: Add support for nonempty_improper_list/2. +convert(Mod, {type,Anno,maybe_improper_list,[]}, State, Stack, VarDict) -> + convert(Mod, {type,Anno,list,[]}, State, Stack, VarDict); +convert(Mod, {type,A,maybe_improper_list,[Cont,_Ter]}, State, Stack, VarDict) -> + convert(Mod, {type,A,list,[Cont]}, State, Stack, VarDict); +convert(Mod, {type,A,nonempty_maybe_improper_list,[]}, State, Stack, VarDict) -> + convert(Mod, {type,A,nonempty_list,[]}, State, Stack, VarDict); +convert(Mod, {type,A,nonempty_maybe_improper_list,[Cont,_Term]}, State, Stack, + VarDict) -> + convert(Mod, {type,A,nonempty_list,[Cont]}, State, Stack, VarDict); +convert(Mod, {type,A,iodata,[]}, State, Stack, VarDict) -> + RealType = {type,A,union,[{type,A,binary,[]},{type,A,iolist,[]}]}, + convert(Mod, RealType, State, Stack, VarDict); +convert(Mod, {T,_,Name,[]}, State, Stack, VarDict) when ?IS_TYPE_TAG(T) -> + case ordsets:is_element(Name, ?STD_TYPES_0) of + true -> + {ok, {simple,proper_types:Name()}, State}; + false -> + convert_maybe_hard_adt(Mod, Name, [], State, Stack, VarDict) + end; +convert(Mod, {T,_,Name,ArgForms}, State, Stack, VarDict) when ?IS_TYPE_TAG(T) -> + convert_maybe_hard_adt(Mod, Name, ArgForms, State, Stack, VarDict); +convert(_Mod, TypeForm, _State, _Stack, _VarDict) -> + {error, {unsupported_type,TypeForm}}. + +-spec concat_bitstrings([bitstring()]) -> bitstring(). +concat_bitstrings(BitStrings) -> + concat_bitstrings_tr(BitStrings, <<>>). + +-spec concat_bitstrings_tr([bitstring()], bitstring()) -> bitstring(). +concat_bitstrings_tr([], Acc) -> + Acc; +concat_bitstrings_tr([BitString | Rest], Acc) -> + concat_bitstrings_tr(Rest, <<Acc/bits,BitString/bits>>). + +-spec concat_binary_gens(fin_type(), fin_type()) -> fin_type(). +concat_binary_gens(HeadType, TailType) -> + ?LET({H,T}, {HeadType,TailType}, <<H/bits,T/bits>>). + +-spec convert_fun(mod_name(), arity(), abs_type(), state(), stack(), + var_dict()) -> rich_result2(ret_type(),state()). +convert_fun(Mod, Arity, Range, State, Stack, VarDict) -> + case convert(Mod, Range, State, ['fun' | Stack], VarDict) of + {ok,{simple,RangeType},NewState} -> + {ok, {simple,proper_types:function(Arity,RangeType)}, NewState}; + {ok,{rec,RecFun,RecArgs},NewState} -> + case at_toplevel(RecArgs, Stack) of + true -> base_case_error(Stack); + false -> convert_rec_fun(Arity, RecFun, RecArgs, NewState) + end; + {error,_Reason} = Error -> + Error + end. + +-spec convert_rec_fun(arity(), rec_fun(), rec_args(), state()) -> + {'ok',ret_type(),state()}. +convert_rec_fun(Arity, RecFun, RecArgs, State) -> + %% We bind the generated value by size. + NewRecFun = + fun(GenFuns,Size) -> + proper_types:function(Arity, RecFun(GenFuns,Size)) + end, + NewRecArgs = clean_rec_args(RecArgs), + {ok, {rec,NewRecFun,NewRecArgs}, State}. + +-spec convert_list(mod_name(), boolean(), abs_type(), state(), stack(), + var_dict()) -> rich_result2(ret_type(),state()). +convert_list(Mod, NonEmpty, ElemForm, State, Stack, VarDict) -> + case convert(Mod, ElemForm, State, [list | Stack], VarDict) of + {ok,{simple,ElemType},NewState} -> + InnerType = proper_types:list(ElemType), + FinType = case NonEmpty of + true -> proper_types:non_empty(InnerType); + false -> InnerType + end, + {ok, {simple,FinType}, NewState}; + {ok,{rec,RecFun,RecArgs},NewState} -> + case {at_toplevel(RecArgs,Stack), NonEmpty} of + {true,true} -> + base_case_error(Stack); + {true,false} -> + NewRecFun = + fun(GenFuns,Size) -> + ElemGen = fun(S) -> ?LAZY(RecFun(GenFuns,S)) end, + proper_types:distlist(Size, ElemGen, false) + end, + NewRecArgs = clean_rec_args(RecArgs), + {ok, {rec,NewRecFun,NewRecArgs}, NewState}; + {false,_} -> + {NewRecFun,NewRecArgs} = + convert_rec_list(RecFun, RecArgs, NonEmpty), + {ok, {rec,NewRecFun,NewRecArgs}, NewState} + end; + {error,_Reason} = Error -> + Error + end. + +-spec convert_rec_list(rec_fun(), rec_args(), boolean()) -> + {rec_fun(),rec_args()}. +convert_rec_list(RecFun, [{true,FullTypeRef}] = RecArgs, NonEmpty) -> + {NewRecFun,_NormalRecArgs} = + convert_normal_rec_list(RecFun, RecArgs, NonEmpty), + AltRecFun = + fun([InstListGen],Size) -> + InstTypesList = + proper_types:get_prop(internal_types, InstListGen(Size)), + proper_types:fixed_list([RecFun([fun(_Size) -> I end],0) + || I <- InstTypesList]) + end, + NewRecArgs = [{{list,NonEmpty,AltRecFun},FullTypeRef}], + {NewRecFun, NewRecArgs}; +convert_rec_list(RecFun, RecArgs, NonEmpty) -> + convert_normal_rec_list(RecFun, RecArgs, NonEmpty). + +-spec convert_normal_rec_list(rec_fun(), rec_args(), boolean()) -> + {rec_fun(),rec_args()}. +convert_normal_rec_list(RecFun, RecArgs, NonEmpty) -> + NewRecFun = fun(GenFuns,Size) -> + ElemGen = fun(S) -> RecFun(GenFuns, S) end, + proper_types:distlist(Size, ElemGen, NonEmpty) + end, + NewRecArgs = clean_rec_args(RecArgs), + {NewRecFun, NewRecArgs}. + +-spec convert_tuple(mod_name(), [abs_type()], boolean(), state(), stack(), + var_dict()) -> rich_result2(ret_type(),state()). +convert_tuple(Mod, ElemForms, ToList, State, Stack, VarDict) -> + case process_list(Mod, ElemForms, State, [tuple | Stack], VarDict) of + {ok,RetTypes,NewState} -> + case combine_ret_types(RetTypes, {tuple,ToList}) of + {simple,_FinType} = RetType -> + {ok, RetType, NewState}; + {rec,_RecFun,RecArgs} = RetType -> + case at_toplevel(RecArgs, Stack) of + true -> base_case_error(Stack); + false -> {ok, RetType, NewState} + end + end; + {error,_Reason} = Error -> + Error + end. + +-spec convert_union(mod_name(), [abs_type()], state(), stack(), var_dict()) -> + rich_result2(ret_type(),state()). +convert_union(Mod, ChoiceForms, State, Stack, VarDict) -> + case process_list(Mod, ChoiceForms, State, [union | Stack], VarDict) of + {ok,RawChoices,NewState} -> + ProcessChoice = fun(T,A) -> process_choice(T,A,Stack) end, + {RevSelfRecs,RevNonSelfRecs,RevNonRecs} = + lists:foldl(ProcessChoice, {[],[],[]}, RawChoices), + case {lists:reverse(RevSelfRecs),lists:reverse(RevNonSelfRecs), + lists:reverse(RevNonRecs)} of + {_SelfRecs,[],[]} -> + base_case_error(Stack); + {[],NonSelfRecs,NonRecs} -> + {ok, combine_ret_types(NonRecs ++ NonSelfRecs, union), + NewState}; + {SelfRecs,NonSelfRecs,NonRecs} -> + {BCaseRecFun,BCaseRecArgs} = + case combine_ret_types(NonRecs ++ NonSelfRecs, union) of + {simple,BCaseType} -> + {fun([],_Size) -> BCaseType end,[]}; + {rec,BCRecFun,BCRecArgs} -> + {BCRecFun,BCRecArgs} + end, + NumBCaseGens = length(BCaseRecArgs), + [ParentRef | _Upper] = Stack, + FallbackRecFun = fun([SelfGen],_Size) -> SelfGen(0) end, + FallbackRecArgs = [{false,ParentRef}], + FallbackRetType = {rec,FallbackRecFun,FallbackRecArgs}, + {rec,RCaseRecFun,RCaseRecArgs} = + combine_ret_types([FallbackRetType] ++ SelfRecs + ++ NonSelfRecs, wunion), + NewRecFun = + fun(AllGens,Size) -> + {BCaseGens,RCaseGens} = + lists:split(NumBCaseGens, AllGens), + case Size of + 0 -> BCaseRecFun(BCaseGens,0); + _ -> RCaseRecFun(RCaseGens,Size) + end + end, + NewRecArgs = BCaseRecArgs ++ RCaseRecArgs, + {ok, {rec,NewRecFun,NewRecArgs}, NewState} + end; + {error,_Reason} = Error -> + Error + end. + +-spec process_choice(ret_type(), {[ret_type()],[ret_type()],[ret_type()]}, + stack()) -> {[ret_type()],[ret_type()],[ret_type()]}. +process_choice({simple,_} = RetType, {SelfRecs,NonSelfRecs,NonRecs}, _Stack) -> + {SelfRecs, NonSelfRecs, [RetType | NonRecs]}; +process_choice({rec,RecFun,RecArgs}, {SelfRecs,NonSelfRecs,NonRecs}, Stack) -> + case at_toplevel(RecArgs, Stack) of + true -> + case partition_by_toplevel(RecArgs, Stack, true) of + {[],[],_,_} -> + NewRecArgs = clean_rec_args(RecArgs), + {[{rec,RecFun,NewRecArgs} | SelfRecs], NonSelfRecs, + NonRecs}; + {SelfRecArgs,SelfPos,OtherRecArgs,_OtherPos} -> + NumInstances = length(SelfRecArgs), + IsListInst = fun({true,_FTRef}) -> false + ; ({{list,_NE,_AltRecFun},_FTRef}) -> true + end, + NewRecFun = + case proper_arith:filter(IsListInst,SelfRecArgs) of + {[],[]} -> + no_list_inst_rec_fun(RecFun,NumInstances, + SelfPos); + {[{{list,NonEmpty,AltRecFun},_}],[ListInstPos]} -> + list_inst_rec_fun(AltRecFun,NumInstances, + SelfPos,NonEmpty,ListInstPos) + end, + [{_B,SelfRef} | _] = SelfRecArgs, + NewRecArgs = + [{false,SelfRef} | clean_rec_args(OtherRecArgs)], + {[{rec,NewRecFun,NewRecArgs} | SelfRecs], NonSelfRecs, + NonRecs} + end; + false -> + NewRecArgs = clean_rec_args(RecArgs), + {SelfRecs, [{rec,RecFun,NewRecArgs} | NonSelfRecs], NonRecs} + end. + +-spec no_list_inst_rec_fun(rec_fun(), pos_integer(), [position()]) -> rec_fun(). +no_list_inst_rec_fun(RecFun, NumInstances, SelfPos) -> + fun([SelfGen|OtherGens], Size) -> + ?LETSHRINK( + Instances, + %% Size distribution will be a little off if both normal and + %% instance-accepting generators are present. + lists:duplicate(NumInstances, SelfGen(Size div NumInstances)), + begin + InstGens = [fun(_Size) -> proper_types:exactly(I) end + || I <- Instances], + AllGens = proper_arith:insert(InstGens, SelfPos, OtherGens), + RecFun(AllGens, Size) + end) + end. + +-spec list_inst_rec_fun(rec_fun(), pos_integer(), [position()], boolean(), + position()) -> rec_fun(). +list_inst_rec_fun(AltRecFun, NumInstances, SelfPos, NonEmpty, ListInstPos) -> + fun([SelfGen|OtherGens], Size) -> + ?LETSHRINK( + AllInsts, + lists:duplicate(NumInstances - 1, SelfGen(Size div NumInstances)) + ++ proper_types:distlist(Size div NumInstances, SelfGen, NonEmpty), + begin + {Instances,InstList} = lists:split(NumInstances - 1, AllInsts), + InstGens = [fun(_Size) -> proper_types:exactly(I) end + || I <- Instances], + InstTypesList = [proper_types:exactly(I) || I <- InstList], + InstListGen = + fun(_Size) -> proper_types:fixed_list(InstTypesList) end, + AllInstGens = proper_arith:list_insert(ListInstPos, InstListGen, + InstGens), + AllGens = proper_arith:insert(AllInstGens, SelfPos, OtherGens), + AltRecFun(AllGens, Size) + end) + end. + +-spec convert_maybe_hard_adt(mod_name(), type_name(), [abs_type()], state(), + stack(), var_dict()) -> + rich_result2(ret_type(),state()). +convert_maybe_hard_adt(Mod, Name, ArgForms, State, Stack, VarDict) -> + Arity = length(ArgForms), + case orddict:find({Name,Arity}, ?HARD_ADTS) of + {ok,Mod} -> + convert_custom(Mod, Mod, Name, ArgForms, State, Stack, VarDict); + {ok,ADTMod} -> + A = ?anno(0), + ADT = {remote_type,A,[{atom,A,ADTMod},{atom,A,Name},ArgForms]}, + convert(Mod, ADT, State, Stack, VarDict); + error -> + convert_custom(Mod, Mod, Name, ArgForms, State, Stack, VarDict) + end. + +-spec convert_custom(mod_name(), mod_name(), type_name(), [abs_type()], state(), + stack(), var_dict()) -> rich_result2(ret_type(),state()). +convert_custom(Mod, RemMod, Name, ArgForms, State, Stack, VarDict) -> + case process_list(Mod, ArgForms, State, Stack, VarDict) of + {ok,Args,NewState} -> + Arity = length(Args), + TypeRef = {type,Name,Arity}, + FullTypeRef = {RemMod,type,Name,Args}, + convert_type(TypeRef, FullTypeRef, NewState, Stack); + {error,_Reason} = Error -> + Error + end. + +-spec convert_record(mod_name(), type_name(), [abs_type()], state(), stack(), + var_dict()) -> rich_result2(ret_type(),state()). +convert_record(Mod, Name, RawSubsts, State, Stack, VarDict) -> + Substs = [{N,T} || {type,_,field_type,[{atom,_,N},T]} <- RawSubsts], + {SubstFields,SubstTypeForms} = lists:unzip(Substs), + case process_list(Mod, SubstTypeForms, State, Stack, VarDict) of + {ok,SubstTypes,NewState} -> + SubstsDict = dict:from_list(lists:zip(SubstFields, SubstTypes)), + TypeRef = {record,Name,0}, + FullTypeRef = {Mod,record,Name,SubstsDict}, + convert_type(TypeRef, FullTypeRef, NewState, Stack); + {error,_Reason} = Error -> + Error + end. + +-spec convert_type(type_ref(), full_type_ref(), state(), stack()) -> + rich_result2(ret_type(),state()). +convert_type(TypeRef, {Mod,_Kind,_Name,_Spec} = FullTypeRef, State, Stack) -> + case stack_position(FullTypeRef, Stack) of + none -> + case get_type_repr(Mod, TypeRef, false, State) of + {ok,TypeRepr,NewState} -> + convert_new_type(TypeRef, FullTypeRef, TypeRepr, NewState, + Stack); + {error,_Reason} = Error -> + Error + end; + 1 -> + base_case_error(Stack); + _Pos -> + {ok, {rec,fun([Gen],Size) -> Gen(Size) end,[{true,FullTypeRef}]}, + State} + end. + +-spec convert_new_type(type_ref(), full_type_ref(), type_repr(), state(), + stack()) -> rich_result2(ret_type(),state()). +convert_new_type(_TypeRef, {_Mod,type,_Name,[]}, + {cached,FinType,_TypeForm,_SymbInfo}, State, _Stack) -> + {ok, {simple,FinType}, State}; +convert_new_type(TypeRef, {Mod,type,_Name,Args} = FullTypeRef, + {abs_type,TypeForm,Vars,SymbInfo}, State, Stack) -> + VarDict = dict:from_list(lists:zip(Vars, Args)), + case convert(Mod, TypeForm, State, [FullTypeRef | Stack], VarDict) of + {ok, {simple,ImmFinType}, NewState} -> + FinType = case SymbInfo of + not_symb -> + ImmFinType; + {orig_abs,_OrigAbsType} -> + proper_symb:internal_well_defined(ImmFinType) + end, + FinalState = case Vars of + [] -> cache_type(Mod, TypeRef, FinType, TypeForm, + SymbInfo, NewState); + _ -> NewState + end, + {ok, {simple,FinType}, FinalState}; + {ok, {rec,RecFun,RecArgs}, NewState} -> + convert_maybe_rec(FullTypeRef, SymbInfo, RecFun, RecArgs, NewState, + Stack); + {error,_Reason} = Error -> + Error + end; +convert_new_type(_TypeRef, {Mod,record,Name,SubstsDict} = FullTypeRef, + {abs_record,OrigFields}, State, Stack) -> + Fields = [case dict:find(FieldName, SubstsDict) of + {ok,NewFieldType} -> NewFieldType; + error -> OrigFieldType + end + || {FieldName,OrigFieldType} <- OrigFields], + case convert_tuple(Mod, [{atom,0,Name} | Fields], false, State, + [FullTypeRef | Stack], dict:new()) of + {ok, {simple,_FinType}, _NewState} = Result -> + Result; + {ok, {rec,RecFun,RecArgs}, NewState} -> + convert_maybe_rec(FullTypeRef, not_symb, RecFun, RecArgs, NewState, + Stack); + {error,_Reason} = Error -> + Error + end. + +-spec cache_type(mod_name(), type_ref(), fin_type(), abs_type(), symb_info(), + state()) -> state(). +cache_type(Mod, TypeRef, FinType, TypeForm, SymbInfo, + #state{types = Types} = State) -> + TypeRepr = {cached,FinType,TypeForm,SymbInfo}, + ModTypes = dict:fetch(Mod, Types), + NewModTypes = dict:store(TypeRef, TypeRepr, ModTypes), + NewTypes = dict:store(Mod, NewModTypes, Types), + State#state{types = NewTypes}. + +-spec convert_maybe_rec(full_type_ref(), symb_info(), rec_fun(), rec_args(), + state(), stack()) -> rich_result2(ret_type(),state()). +convert_maybe_rec(FullTypeRef, SymbInfo, RecFun, RecArgs, State, Stack) -> + case at_toplevel(RecArgs, Stack) of + true -> base_case_error(Stack); + false -> safe_convert_maybe_rec(FullTypeRef, SymbInfo, RecFun, RecArgs, + State) + end. + +-spec safe_convert_maybe_rec(full_type_ref(),symb_info(),rec_fun(),rec_args(), + state()) -> rich_result2(ret_type(),state()). +safe_convert_maybe_rec(FullTypeRef, SymbInfo, RecFun, RecArgs, State) -> + case partition_rec_args(FullTypeRef, RecArgs, false) of + {[],[],_,_} -> + {ok, {rec,RecFun,RecArgs}, State}; + {MyRecArgs,MyPos,OtherRecArgs,_OtherPos} -> + case lists:all(fun({B,_T}) -> B =:= false end, MyRecArgs) of + true -> convert_rec_type(SymbInfo, RecFun, MyPos, OtherRecArgs, + State); + false -> {error, {internal,true_rec_arg_reached_type}} + end + end. + +-spec convert_rec_type(symb_info(), rec_fun(), [position()], rec_args(), + state()) -> {ok, ret_type(), state()}. +convert_rec_type(SymbInfo, RecFun, MyPos, [], State) -> + NumRecArgs = length(MyPos), + M = fun(GenFun) -> + fun(Size) -> + GenFuns = lists:duplicate(NumRecArgs, GenFun), + RecFun(GenFuns, erlang:max(0,Size - 1)) + end + end, + SizedGen = y(M), + ImmFinType = ?SIZED(Size,SizedGen(Size + 1)), + FinType = case SymbInfo of + not_symb -> + ImmFinType; + {orig_abs,_OrigAbsType} -> + proper_symb:internal_well_defined(ImmFinType) + end, + {ok, {simple,FinType}, State}; +convert_rec_type(_SymbInfo, RecFun, MyPos, OtherRecArgs, State) -> + NumRecArgs = length(MyPos), + NewRecFun = + fun(OtherGens,TopSize) -> + M = fun(GenFun) -> + fun(Size) -> + GenFuns = lists:duplicate(NumRecArgs, GenFun), + AllGens = + proper_arith:insert(GenFuns, MyPos, OtherGens), + RecFun(AllGens, erlang:max(0,Size - 1)) + end + end, + (y(M))(TopSize) + end, + NewRecArgs = clean_rec_args(OtherRecArgs), + {ok, {rec,NewRecFun,NewRecArgs}, State}. + +%% Y Combinator: Read more at http://bc.tech.coop/blog/070611.html. +-spec y(fun((fun((T) -> S)) -> fun((T) -> S))) -> fun((T) -> S). +y(M) -> + G = fun(F) -> + M(fun(A) -> (F(F))(A) end) + end, + G(G). + +-spec process_list(mod_name(), [abs_type() | ret_type()], state(), stack(), + var_dict()) -> rich_result2([ret_type()],state()). +process_list(Mod, RawTypes, State, Stack, VarDict) -> + Process = fun({simple,_FinType} = Type, {ok,Types,State1}) -> + {ok, [Type|Types], State1}; + ({rec,_RecFun,_RecArgs} = Type, {ok,Types,State1}) -> + {ok, [Type|Types], State1}; + (TypeForm, {ok,Types,State1}) -> + case convert(Mod, TypeForm, State1, Stack, VarDict) of + {ok,Type,State2} -> {ok,[Type|Types],State2}; + {error,_} = Err -> Err + end; + (_RawType, {error,_} = Err) -> + Err + end, + case lists:foldl(Process, {ok,[],State}, RawTypes) of + {ok,RevTypes,NewState} -> + {ok, lists:reverse(RevTypes), NewState}; + {error,_Reason} = Error -> + Error + end. + +-spec convert_integer(abs_expr(), state()) -> rich_result2(ret_type(),state()). +convert_integer(Expr, State) -> + case eval_int(Expr) of + {ok,Int} -> {ok, {simple,proper_types:exactly(Int)}, State}; + error -> expr_error(invalid_int_const, Expr) + end. + +-spec eval_int(abs_expr()) -> tagged_result(integer()). +eval_int(Expr) -> + NoBindings = erl_eval:new_bindings(), + try erl_eval:expr(Expr, NoBindings) of + {value,Value,_NewBindings} when is_integer(Value) -> + {ok, Value}; + _ -> + error + catch + error:_ -> + error + end. + +-spec expr_error(atom(), abs_expr()) -> {'error',term()}. +expr_error(Reason, Expr) -> + {error, {Reason,lists:flatten(erl_pp:expr(Expr))}}. + +-spec expr_error(atom(), abs_expr(), abs_expr()) -> {'error',term()}. +expr_error(Reason, Expr1, Expr2) -> + Str1 = lists:flatten(erl_pp:expr(Expr1)), + Str2 = lists:flatten(erl_pp:expr(Expr2)), + {error, {Reason,Str1,Str2}}. + +-spec base_case_error(stack()) -> {'error',term()}. +%% TODO: This might confuse, since it doesn't record the arguments to parametric +%% types or the type subsitutions of a record. +base_case_error([{Mod,type,Name,Args} | _Upper]) -> + Arity = length(Args), + {error, {no_base_case,{Mod,type,Name,Arity}}}; +base_case_error([{Mod,record,Name,_SubstsDict} | _Upper]) -> + {error, {no_base_case,{Mod,record,Name}}}. + + +%%------------------------------------------------------------------------------ +%% Helper datatypes handling functions +%%------------------------------------------------------------------------------ + +-spec stack_position(full_type_ref(), stack()) -> 'none' | pos_integer(). +stack_position(FullTypeRef, Stack) -> + SameType = fun(A) -> same_full_type_ref(A,FullTypeRef) end, + case proper_arith:find_first(SameType, Stack) of + {Pos,_} -> Pos; + none -> none + end. + +-spec partition_by_toplevel(rec_args(), stack(), boolean()) -> + {rec_args(),[position()],rec_args(),[position()]}. +partition_by_toplevel(RecArgs, [], _OnlyInstanceAccepting) -> + {[],[],RecArgs,lists:seq(1,length(RecArgs))}; +partition_by_toplevel(RecArgs, [_Parent | _Upper], _OnlyInstanceAccepting) + when is_atom(_Parent) -> + {[],[],RecArgs,lists:seq(1,length(RecArgs))}; +partition_by_toplevel(RecArgs, [Parent | _Upper], OnlyInstanceAccepting) -> + partition_rec_args(Parent, RecArgs, OnlyInstanceAccepting). + +-spec at_toplevel(rec_args(), stack()) -> boolean(). +at_toplevel(RecArgs, Stack) -> + case partition_by_toplevel(RecArgs, Stack, false) of + {[],[],_,_} -> false; + _ -> true + end. + +-spec partition_rec_args(full_type_ref(), rec_args(), boolean()) -> + {rec_args(),[position()],rec_args(),[position()]}. +partition_rec_args(FullTypeRef, RecArgs, OnlyInstanceAccepting) -> + SameType = + case OnlyInstanceAccepting of + true -> fun({false,_T}) -> false + ; ({_B,T}) -> same_full_type_ref(T,FullTypeRef) end; + false -> fun({_B,T}) -> same_full_type_ref(T,FullTypeRef) end + end, + proper_arith:partition(SameType, RecArgs). + +%% Tuples can be of 0 arity, unions of 1 and wunions at least of 2. +-spec combine_ret_types([ret_type()], {'tuple',boolean()} | 'union' + | 'wunion') -> ret_type(). +combine_ret_types(RetTypes, EnclosingType) -> + case lists:all(fun is_simple_ret_type/1, RetTypes) of + true -> + %% This should never happen for wunion. + Combine = case EnclosingType of + {tuple,false} -> fun proper_types:tuple/1; + {tuple,true} -> fun proper_types:fixed_list/1; + union -> fun proper_types:union/1 + end, + FinTypes = [T || {simple,T} <- RetTypes], + {simple, Combine(FinTypes)}; + false -> + NumTypes = length(RetTypes), + {RevRecFuns,RevRecArgsList,NumRecs} = + lists:foldl(fun add_ret_type/2, {[],[],0}, RetTypes), + RecFuns = lists:reverse(RevRecFuns), + RecArgsList = lists:reverse(RevRecArgsList), + RecArgLens = [length(RecArgs) || RecArgs <- RecArgsList], + RecFunInfo = {NumTypes,NumRecs,RecArgLens,RecFuns}, + FlatRecArgs = lists:flatten(RecArgsList), + {NewRecFun,NewRecArgs} = + case EnclosingType of + {tuple,ToList} -> + {tuple_rec_fun(RecFunInfo,ToList), + soft_clean_rec_args(FlatRecArgs,RecFunInfo,ToList)}; + union -> + {union_rec_fun(RecFunInfo),clean_rec_args(FlatRecArgs)}; + wunion -> + {wunion_rec_fun(RecFunInfo), + clean_rec_args(FlatRecArgs)} + end, + {rec, NewRecFun, NewRecArgs} + end. + +-spec tuple_rec_fun(rec_fun_info(), boolean()) -> rec_fun(). +tuple_rec_fun({_NumTypes,NumRecs,RecArgLens,RecFuns}, ToList) -> + Combine = case ToList of + true -> fun proper_types:fixed_list/1; + false -> fun proper_types:tuple/1 + end, + fun(AllGFs,TopSize) -> + Size = TopSize div NumRecs, + GFsList = proper_arith:unflatten(AllGFs, RecArgLens), + ArgsList = [[GenFuns,Size] || GenFuns <- GFsList], + ZipFun = fun erlang:apply/2, + Combine(lists:zipwith(ZipFun, RecFuns, ArgsList)) + end. + +-spec union_rec_fun(rec_fun_info()) -> rec_fun(). +union_rec_fun({_NumTypes,_NumRecs,RecArgLens,RecFuns}) -> + fun(AllGFs,Size) -> + GFsList = proper_arith:unflatten(AllGFs, RecArgLens), + ArgsList = [[GenFuns,Size] || GenFuns <- GFsList], + ZipFun = fun(F,A) -> ?LAZY(apply(F,A)) end, + proper_types:union(lists:zipwith(ZipFun, RecFuns, ArgsList)) + end. + +-spec wunion_rec_fun(rec_fun_info()) -> rec_fun(). +wunion_rec_fun({NumTypes,_NumRecs,RecArgLens,RecFuns}) -> + fun(AllGFs,Size) -> + GFsList = proper_arith:unflatten(AllGFs, RecArgLens), + ArgsList = [[GenFuns,Size] || GenFuns <- GFsList], + ZipFun = fun(W,F,A) -> {W,?LAZY(apply(F,A))} end, + RecWeight = erlang:max(1, Size div (NumTypes - 1)), + Weights = [1 | lists:duplicate(NumTypes - 1, RecWeight)], + WeightedChoices = lists:zipwith3(ZipFun, Weights, RecFuns, ArgsList), + proper_types:wunion(WeightedChoices) + end. + +-spec add_ret_type(ret_type(), {[rec_fun()],[rec_args()],non_neg_integer()}) -> + {[rec_fun()],[rec_args()],non_neg_integer()}. +add_ret_type({simple,FinType}, {RecFuns,RecArgsList,NumRecs}) -> + {[fun([],_) -> FinType end | RecFuns], [[] | RecArgsList], NumRecs}; +add_ret_type({rec,RecFun,RecArgs}, {RecFuns,RecArgsList,NumRecs}) -> + {[RecFun | RecFuns], [RecArgs | RecArgsList], NumRecs + 1}. + +-spec is_simple_ret_type(ret_type()) -> boolean(). +is_simple_ret_type({simple,_FinType}) -> + true; +is_simple_ret_type({rec,_RecFun,_RecArgs}) -> + false. + +-spec clean_rec_args(rec_args()) -> rec_args(). +clean_rec_args(RecArgs) -> + [{false,F} || {_B,F} <- RecArgs]. + +-spec soft_clean_rec_args(rec_args(), rec_fun_info(), boolean()) -> rec_args(). +soft_clean_rec_args(RecArgs, RecFunInfo, ToList) -> + soft_clean_rec_args_tr(RecArgs, [], RecFunInfo, ToList, false, 1). + +-spec soft_clean_rec_args_tr(rec_args(), rec_args(), rec_fun_info(), boolean(), + boolean(), position()) -> rec_args(). +soft_clean_rec_args_tr([], Acc, _RecFunInfo, _ToList, _FoundListInst, _Pos) -> + lists:reverse(Acc); +soft_clean_rec_args_tr([{{list,_NonEmpty,_AltRecFun},FTRef} | Rest], Acc, + RecFunInfo, ToList, true, Pos) -> + NewArg = {false,FTRef}, + soft_clean_rec_args_tr(Rest, [NewArg|Acc], RecFunInfo, ToList, true, Pos+1); +soft_clean_rec_args_tr([{{list,NonEmpty,AltRecFun},FTRef} | Rest], Acc, + RecFunInfo, ToList, false, Pos) -> + {NumTypes,NumRecs,RecArgLens,RecFuns} = RecFunInfo, + AltRecFunPos = get_group(Pos, RecArgLens), + AltRecFuns = proper_arith:list_update(AltRecFunPos, AltRecFun, RecFuns), + AltRecFunInfo = {NumTypes,NumRecs,RecArgLens,AltRecFuns}, + NewArg = {{list,NonEmpty,tuple_rec_fun(AltRecFunInfo,ToList)},FTRef}, + soft_clean_rec_args_tr(Rest, [NewArg|Acc], RecFunInfo, ToList, true, Pos+1); +soft_clean_rec_args_tr([Arg | Rest], Acc, RecFunInfo, ToList, FoundListInst, + Pos) -> + soft_clean_rec_args_tr(Rest, [Arg | Acc], RecFunInfo, ToList, FoundListInst, + Pos+1). + +-spec get_group(pos_integer(), [non_neg_integer()]) -> pos_integer(). +get_group(Pos, AllMembers) -> + get_group_tr(Pos, AllMembers, 1). + +-spec get_group_tr(pos_integer(), [non_neg_integer()], pos_integer()) -> + pos_integer(). +get_group_tr(Pos, [Members | Rest], GroupNum) -> + case Pos =< Members of + true -> GroupNum; + false -> get_group_tr(Pos - Members, Rest, GroupNum + 1) + end. + +-spec same_full_type_ref(full_type_ref(), term()) -> boolean(). +same_full_type_ref({SameMod,type,SameName,Args1}, + {SameMod,type,SameName,Args2}) -> + length(Args1) =:= length(Args2) + andalso lists:all(fun({A,B}) -> same_ret_type(A,B) end, + lists:zip(Args1, Args2)); +same_full_type_ref({SameMod,record,SameName,SubstsDict1}, + {SameMod,record,SameName,SubstsDict2}) -> + same_substs_dict(SubstsDict1, SubstsDict2); +same_full_type_ref(_, _) -> + false. + +-spec same_ret_type(ret_type(), ret_type()) -> boolean(). +same_ret_type({simple,FinType1}, {simple,FinType2}) -> + same_fin_type(FinType1, FinType2); +same_ret_type({rec,RecFun1,RecArgs1}, {rec,RecFun2,RecArgs2}) -> + NumRecArgs = length(RecArgs1), + length(RecArgs2) =:= NumRecArgs + andalso lists:all(fun({A1,A2}) -> same_rec_arg(A1,A2,NumRecArgs) end, + lists:zip(RecArgs1,RecArgs2)) + andalso same_rec_fun(RecFun1, RecFun2, NumRecArgs); +same_ret_type(_, _) -> + false. + +%% TODO: Is this too strict? +-spec same_rec_arg(rec_arg(), rec_arg(), arity()) -> boolean(). +same_rec_arg({{list,SameBool,AltRecFun1},FTRef1}, + {{list,SameBool,AltRecFun2},FTRef2}, NumRecArgs) -> + same_rec_fun(AltRecFun1, AltRecFun2, NumRecArgs) + andalso same_full_type_ref(FTRef1, FTRef2); +same_rec_arg({true,FTRef1}, {true,FTRef2}, _NumRecArgs) -> + same_full_type_ref(FTRef1, FTRef2); +same_rec_arg({false,FTRef1}, {false,FTRef2}, _NumRecArgs) -> + same_full_type_ref(FTRef1, FTRef2); +same_rec_arg(_, _, _NumRecArgs) -> + false. + +-spec same_substs_dict(substs_dict(), substs_dict()) -> boolean(). +same_substs_dict(SubstsDict1, SubstsDict2) -> + SameKVPair = fun({{_K,V1},{_K,V2}}) -> same_ret_type(V1,V2); + (_) -> false + end, + SubstsKVList1 = lists:sort(dict:to_list(SubstsDict1)), + SubstsKVList2 = lists:sort(dict:to_list(SubstsDict2)), + length(SubstsKVList1) =:= length(SubstsKVList2) + andalso lists:all(SameKVPair, lists:zip(SubstsKVList1,SubstsKVList2)). + +-spec same_fin_type(fin_type(), fin_type()) -> boolean(). +same_fin_type(Type1, Type2) -> + proper_types:equal_types(Type1, Type2). + +-spec same_rec_fun(rec_fun(), rec_fun(), arity()) -> boolean(). +same_rec_fun(RecFun1, RecFun2, NumRecArgs) -> + %% It's ok that we return a type, even if there's a 'true' for use of + %% an instance. + GenFun = fun(_Size) -> proper_types:exactly('$dummy') end, + GenFuns = lists:duplicate(NumRecArgs,GenFun), + same_fin_type(RecFun1(GenFuns,0), RecFun2(GenFuns,0)). diff --git a/lib/eldap/vsn.mk b/lib/eldap/vsn.mk index 99c474d588..721387d97d 100644 --- a/lib/eldap/vsn.mk +++ b/lib/eldap/vsn.mk @@ -1 +1 @@ -ELDAP_VSN = 1.2.1 +ELDAP_VSN = 1.2.2 diff --git a/lib/hipe/cerl/erl_types.erl b/lib/hipe/cerl/erl_types.erl index 58060361af..02e1625965 100644 --- a/lib/hipe/cerl/erl_types.erl +++ b/lib/hipe/cerl/erl_types.erl @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2003-2015. All Rights Reserved. +%% Copyright Ericsson AB 2003-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -4611,7 +4611,7 @@ t_from_form({type, _L, 'fun', [{type, _, any}, Range]}, TypeNames, t_from_form({type, _L, 'fun', [{type, _, product, Domain}, Range]}, TypeNames, ET, S, MR, V, D, L) -> {Dom1, L1} = list_from_form(Domain, TypeNames, ET, S, MR, V, D, L), - {Ran1, L2} = t_from_form(Range, TypeNames, ET, S, MR, V, D - 1, L1), + {Ran1, L2} = t_from_form(Range, TypeNames, ET, S, MR, V, D, L1), {t_fun(Dom1, Ran1), L2}; t_from_form({type, _L, identifier, []}, _TypeNames, _ET, _S, _MR, _V, _D, L) -> {t_identifier(), L}; diff --git a/lib/hipe/test/hipe_SUITE.erl b/lib/hipe/test/hipe_SUITE.erl index 9319b710d9..a5b3924aa8 100644 --- a/lib/hipe/test/hipe_SUITE.erl +++ b/lib/hipe/test/hipe_SUITE.erl @@ -19,9 +19,6 @@ -compile([export_all]). -include_lib("common_test/include/ct.hrl"). -suite() -> - [{ct_hooks, [ts_install_cth]}]. - all() -> [app, appup]. diff --git a/lib/kernel/src/code_server.erl b/lib/kernel/src/code_server.erl index 25dddb1f6c..90b2a06c46 100644 --- a/lib/kernel/src/code_server.erl +++ b/lib/kernel/src/code_server.erl @@ -76,7 +76,7 @@ init(Ref, Parent, [Root,Mode]) -> interactive -> LibDir = filename:append(Root, "lib"), {ok,Dirs} = erl_prim_loader:list_dir(LibDir), - {Paths,_Libs} = make_path(LibDir, Dirs), + Paths = make_path(LibDir, Dirs), UserLibPaths = get_user_lib_dirs(), ["."] ++ UserLibPaths ++ Paths; _ -> @@ -111,7 +111,7 @@ get_user_lib_dirs() -> get_user_lib_dirs_1([Dir|DirList]) -> case erl_prim_loader:list_dir(Dir) of {ok, Dirs} -> - {Paths,_Libs} = make_path(Dir, Dirs), + Paths = make_path(Dir, Dirs), %% Only add paths trailing with ./ebin. [P || P <- Paths, filename:basename(P) =:= "ebin"] ++ get_user_lib_dirs_1(DirList); @@ -371,7 +371,7 @@ handle_call(Other,{_From,_Tag}, S) -> %% make_path(BundleDir, Bundles0) -> Bundles = choose_bundles(Bundles0), - make_path(BundleDir, Bundles, [], []). + make_path(BundleDir, Bundles, []). choose_bundles(Bundles) -> ArchiveExt = archive_extension(), @@ -381,12 +381,10 @@ choose_bundles(Bundles) -> create_bundle(FullName, ArchiveExt) -> BaseName = filename:basename(FullName, ArchiveExt), - case split(BaseName, "-") of - [_, _|_] = Toks -> - VsnStr = lists:last(Toks), + case split_base(BaseName) of + {Name, VsnStr} -> case vsn_to_num(VsnStr) of {ok, VsnNum} -> - Name = join(lists:sublist(Toks, length(Toks)-1),"-"), {Name,VsnNum,FullName}; false -> {FullName,[0],FullName} @@ -457,41 +455,44 @@ choose([{Name,NumVsn,NewFullName}=New|Bs], Acc, ArchiveExt) -> choose([],Acc, _ArchiveExt) -> Acc. -make_path(_,[],Res,Bs) -> - {Res,Bs}; -make_path(BundleDir,[Bundle|Tail],Res,Bs) -> - Dir = filename:append(BundleDir,Bundle), - Ebin = filename:append(Dir,"ebin"), +make_path(_, [], Res) -> + Res; +make_path(BundleDir, [Bundle|Tail], Res) -> + Dir = filename:append(BundleDir, Bundle), + Ebin = filename:append(Dir, "ebin"), %% First try with /ebin - case erl_prim_loader:read_file_info(Ebin) of - {ok,#file_info{type=directory}} -> - make_path(BundleDir,Tail,[Ebin|Res],[Bundle|Bs]); - _ -> + case is_dir(Ebin) of + true -> + make_path(BundleDir, Tail, [Ebin|Res]); + false -> %% Second try with archive Ext = archive_extension(), - Base = filename:basename(Dir, Ext), - Ebin2 = filename:join([filename:dirname(Dir), Base ++ Ext, Base, "ebin"]), + Base = filename:basename(Bundle, Ext), + Ebin2 = filename:join([BundleDir, Base ++ Ext, Base, "ebin"]), Ebins = - case split(Base, "-") of - [_, _|_] = Toks -> - AppName = join(lists:sublist(Toks, length(Toks)-1),"-"), - Ebin3 = filename:join([filename:dirname(Dir), Base ++ Ext, AppName, "ebin"]), + case split_base(Base) of + {AppName,_} -> + Ebin3 = filename:join([BundleDir, Base ++ Ext, + AppName, "ebin"]), [Ebin3, Ebin2, Dir]; _ -> [Ebin2, Dir] end, - try_ebin_dirs(Ebins,BundleDir,Tail,Res,Bundle, Bs) + case try_ebin_dirs(Ebins) of + {ok,FoundEbin} -> + make_path(BundleDir, Tail, [FoundEbin|Res]); + error -> + make_path(BundleDir, Tail, Res) + end end. -try_ebin_dirs([Ebin | Ebins],BundleDir,Tail,Res,Bundle,Bs) -> - case erl_prim_loader:read_file_info(Ebin) of - {ok,#file_info{type=directory}} -> - make_path(BundleDir,Tail,[Ebin|Res],[Bundle|Bs]); - _ -> - try_ebin_dirs(Ebins,BundleDir,Tail,Res,Bundle,Bs) +try_ebin_dirs([Ebin|Ebins]) -> + case is_dir(Ebin) of + true -> {ok,Ebin}; + false -> try_ebin_dirs(Ebins) end; -try_ebin_dirs([],BundleDir,Tail,Res,_Bundle,Bs) -> - make_path(BundleDir,Tail,Res,Bs). +try_ebin_dirs([]) -> + error. %% @@ -609,19 +610,34 @@ exclude(Dir,Path) -> %% %% get_name(Dir) -> - get_name2(get_name1(Dir), []). + get_name_from_splitted(filename:split(Dir)). + +get_name_from_splitted([DirName,"ebin"]) -> + discard_after_hyphen(DirName); +get_name_from_splitted([DirName]) -> + discard_after_hyphen(DirName); +get_name_from_splitted([_|T]) -> + get_name_from_splitted(T); +get_name_from_splitted([]) -> + "". %No name. + +discard_after_hyphen("-"++_) -> + []; +discard_after_hyphen([H|T]) -> + [H|discard_after_hyphen(T)]; +discard_after_hyphen([]) -> + []. -get_name1(Dir) -> - case lists:reverse(filename:split(Dir)) of - ["ebin",DirName|_] -> DirName; - [DirName|_] -> DirName; - _ -> "" % No name ! +split_base(BaseName) -> + case split(BaseName, "-") of + [_, _|_] = Toks -> + Vsn = lists:last(Toks), + AllButLast = lists:droplast(Toks), + {join(AllButLast, "-"),Vsn}; + [_|_] -> + BaseName end. -get_name2([$-|_],Acc) -> lists:reverse(Acc); -get_name2([H|T],Acc) -> get_name2(T,[H|Acc]); -get_name2(_,Acc) -> lists:reverse(Acc). - check_path(Path) -> PathChoice = init:code_path_choice(), ArchiveExt = archive_extension(), @@ -630,23 +646,23 @@ check_path(Path) -> do_check_path([], _PathChoice, _ArchiveExt, Acc) -> {ok, lists:reverse(Acc)}; do_check_path([Dir | Tail], PathChoice, ArchiveExt, Acc) -> - case catch erl_prim_loader:read_file_info(Dir) of - {ok, #file_info{type=directory}} -> + case is_dir(Dir) of + true -> do_check_path(Tail, PathChoice, ArchiveExt, [Dir | Acc]); - _ when PathChoice =:= strict -> + false when PathChoice =:= strict -> %% Be strict. Only use dir as explicitly stated {error, bad_directory}; - _ when PathChoice =:= relaxed -> + false when PathChoice =:= relaxed -> %% Be relaxed case catch lists:reverse(filename:split(Dir)) of {'EXIT', _} -> {error, bad_directory}; ["ebin", App] -> Dir2 = filename:join([App ++ ArchiveExt, App, "ebin"]), - case erl_prim_loader:read_file_info(Dir2) of - {ok, #file_info{type = directory}} -> + case is_dir(Dir2) of + true -> do_check_path(Tail, PathChoice, ArchiveExt, [Dir2 | Acc]); - _ -> + false -> {error, bad_directory} end; ["ebin", App, OptArchive | RevTop] -> @@ -666,10 +682,10 @@ do_check_path([Dir | Tail], PathChoice, ArchiveExt, Acc) -> Top = lists:reverse([OptArchive | RevTop]), filename:join(Top ++ [App ++ ArchiveExt, App, "ebin"]) end, - case erl_prim_loader:read_file_info(Dir2) of - {ok, #file_info{type = directory}} -> + case is_dir(Dir2) of + true -> do_check_path(Tail, PathChoice, ArchiveExt, [Dir2 | Acc]); - _ -> + false -> {error, bad_directory} end; _ -> @@ -768,7 +784,7 @@ init_namedb(Path) -> Db. init_namedb([P|Path], Db) -> - insert_name(P, Db), + insert_dir(P, Db), init_namedb(Path, Db); init_namedb([], _) -> ok. @@ -781,59 +797,39 @@ clear_namedb([], _) -> ok. -endif. -insert_name(Dir, Db) -> - case get_name(Dir) of - Dir -> false; - Name -> insert_name(Name, Dir, Db) - end. +%% Dir must be a complete pathname (not only a name). +insert_dir(Dir, Db) -> + Splitted = filename:split(Dir), + Name = get_name_from_splitted(Splitted), + AppDir = filename:join(del_ebin_1(Splitted)), + do_insert_name(Name, AppDir, Db). insert_name(Name, Dir, Db) -> AppDir = del_ebin(Dir), + do_insert_name(Name, AppDir, Db). + +do_insert_name(Name, AppDir, Db) -> {Base, SubDirs} = archive_subdirs(AppDir), ets:insert(Db, {Name, AppDir, Base, SubDirs}), true. archive_subdirs(AppDir) -> - IsDir = - fun(RelFile) -> - File = filename:join([AppDir, RelFile]), - case erl_prim_loader:read_file_info(File) of - {ok, #file_info{type = directory}} -> - false; - _ -> - true - end - end, - {Base, ArchiveDirs} = all_archive_subdirs(AppDir), - {Base, lists:filter(IsDir, ArchiveDirs)}. - -all_archive_subdirs(AppDir) -> - Ext = archive_extension(), Base = filename:basename(AppDir), - Dirs = - case split(Base, "-") of - [_, _|_] = Toks -> - Base2 = join(lists:sublist(Toks, length(Toks)-1), "-"), - [Base2, Base]; - _ -> - [Base] + Dirs = case split_base(Base) of + {Name, _} -> [Name, Base]; + _ -> [Base] end, + Ext = archive_extension(), try_archive_subdirs(AppDir ++ Ext, Base, Dirs). try_archive_subdirs(Archive, Base, [Dir | Dirs]) -> - ArchiveDir = filename:join([Archive, Dir]), + ArchiveDir = filename:append(Archive, Dir), case erl_prim_loader:list_dir(ArchiveDir) of {ok, Files} -> - IsDir = - fun(RelFile) -> - File = filename:join([ArchiveDir, RelFile]), - case erl_prim_loader:read_file_info(File) of - {ok, #file_info{type = directory}} -> - true; - _ -> - false - end - end, + IsDir = fun(RelFile) -> + File = filename:append(ArchiveDir, RelFile), + is_dir(File) + end, {Dir, lists:filter(IsDir, Files)}; _ -> try_archive_subdirs(Archive, Base, Dirs) @@ -927,22 +923,22 @@ check_pars(Name,Dir) -> end. del_ebin(Dir) -> - case filename:basename(Dir) of - "ebin" -> - Dir2 = filename:dirname(Dir), - Dir3 = filename:dirname(Dir2), - Ext = archive_extension(), - case filename:extension(Dir3) of - E when E =:= Ext -> - %% Strip archive extension - filename:join([filename:dirname(Dir3), - filename:basename(Dir3, Ext)]); - _ -> - Dir2 - end; - _ -> - Dir - end. + filename:join(del_ebin_1(filename:split(Dir))). + +del_ebin_1([Parent,App,"ebin"]) -> + Ext = archive_extension(), + case filename:basename(Parent, Ext) of + Parent -> + %% Plain directory. + [Parent,App]; + Archive -> + %% Archive. + [Archive] + end; +del_ebin_1([H|T]) -> + [H|del_ebin_1(T)]; +del_ebin_1([]) -> + []. replace_name(Dir, Db) -> case get_name(Dir) of @@ -1174,8 +1170,13 @@ mod_to_bin([Dir|Tail], Mod) -> case erl_prim_loader:get_file(File) of error -> mod_to_bin(Tail, Mod); - {ok,Bin,FName} -> - {Mod,Bin,absname(FName)} + {ok,Bin,_} -> + case filename:pathtype(File) of + absolute -> + {Mod,Bin,File}; + _ -> + {Mod,Bin,absname(File)} + end end; mod_to_bin([], Mod) -> %% At last, try also erl_prim_loader's own method @@ -1236,6 +1237,11 @@ do_purge(Mod) -> do_soft_purge(Mod) -> erts_code_purger:soft_purge(Mod). +is_dir(Path) -> + case erl_prim_loader:read_file_info(Path) of + {ok,#file_info{type=directory}} -> true; + _ -> false + end. %%% %%% Loading of multiple modules in parallel. diff --git a/lib/kernel/test/code_SUITE.erl b/lib/kernel/test/code_SUITE.erl index 7f9718a354..383eab94fe 100644 --- a/lib/kernel/test/code_SUITE.erl +++ b/lib/kernel/test/code_SUITE.erl @@ -1023,6 +1023,12 @@ do_code_archive(Config, Root, StripVsn) when is_list(Config) -> {ok, _} = zip:create(Archive, [Base], [{compress, []}, {cwd, PrivDir}]), + %% Create a directory and a file outside of the archive. + OtherFile = filename:join([RootDir,VsnBase,"other","other.txt"]), + OtherContents = ?MODULE:module_info(md5), + filelib:ensure_dir(OtherFile), + ok = file:write_file(OtherFile, OtherContents), + %% Set up ERL_LIBS and start a slave node. {ok, Node} = test_server:start_node(code_archive, slave, @@ -1037,13 +1043,25 @@ do_code_archive(Config, Root, StripVsn) when is_list(Config) -> %% Start the app ok = rpc:call(Node, application, start, [App]), + %% Get the lib dir for the app. + AppLibDir = rpc:call(Node, code, lib_dir, [App]), + io:format("AppLibDir: ~p\n", [AppLibDir]), + AppLibDir = filename:join(RootDir, VsnBase), + %% Access the app priv dir AppPrivDir = rpc:call(Node, code, priv_dir, [App]), AppPrivFile = filename:join([AppPrivDir, "code_archive.txt"]), io:format("AppPrivFile: ~p\n", [AppPrivFile]), - {ok, _Bin, _Path} = + {ok, _Bin, _} = rpc:call(Node, erl_prim_loader, get_file, [AppPrivFile]), + %% Read back the other text file. + OtherDirPath = rpc:call(Node, code, lib_dir, [App,other]), + OtherFilePath = filename:join(OtherDirPath, "other.txt"), + io:format("OtherFilePath: ~p\n", [OtherFilePath]), + {ok, OtherContents, _} = + rpc:call(Node, erl_prim_loader, get_file, [OtherFilePath]), + %% Use the app Tab = code_archive_tab, Key = foo, diff --git a/lib/kernel/test/seq_trace_SUITE.erl b/lib/kernel/test/seq_trace_SUITE.erl index 000994751f..be23a1933f 100644 --- a/lib/kernel/test/seq_trace_SUITE.erl +++ b/lib/kernel/test/seq_trace_SUITE.erl @@ -498,7 +498,13 @@ match_set_seq_token(Config) when is_list(Config) -> exit(P2, timeout), {error, "Test node hung"} end, - ok = check_match_set_seq_token_log(Lbl, Log), + + %% Sort the log on Pid, as events from different processes + %% are not guaranteed to arrive in a certain order to the + %% tracer + SortedLog = lists:keysort(2, Log), + + ok = check_match_set_seq_token_log(Lbl, SortedLog), %% stop_node(Sandbox), ok. @@ -551,13 +557,13 @@ do_match_set_seq_token(Label) -> check_match_set_seq_token_log( Label, - [{trace,C,call,{?MODULE,countdown,[B,Ref]}, {0,Label,0,C,0}}, + [{trace,B,call,{?MODULE,bounce, [Ref]}, {0,Label,2,B,1}}, + {trace,B,call,{?MODULE,bounce, [Ref]}, {0,Label,4,B,3}}, + {trace,B,call,{?MODULE,bounce, [Ref]}, {0,Label,6,B,5}}, + {trace,C,call,{?MODULE,countdown,[B,Ref]}, {0,Label,0,C,0}}, {trace,C,call,{?MODULE,countdown,[B,Ref,3]},{0,Label,0,C,0}}, - {trace,B,call,{?MODULE,bounce, [Ref]}, {0,Label,2,B,1}}, {trace,C,call,{?MODULE,countdown,[B,Ref,2]},{0,Label,2,B,1}}, - {trace,B,call,{?MODULE,bounce, [Ref]}, {0,Label,4,B,3}}, {trace,C,call,{?MODULE,countdown,[B,Ref,1]},{0,Label,4,B,3}}, - {trace,B,call,{?MODULE,bounce, [Ref]}, {0,Label,6,B,5}}, {trace,C,call,{?MODULE,countdown,[B,Ref,0]},{0,Label,6,B,5}} ]) -> ok; diff --git a/lib/observer/src/observer_alloc_wx.erl b/lib/observer/src/observer_alloc_wx.erl index d37623d1cc..220276ac0c 100644 --- a/lib/observer/src/observer_alloc_wx.erl +++ b/lib/observer/src/observer_alloc_wx.erl @@ -250,7 +250,6 @@ sum_alloc_one_instance([],BS,CS,TotalBS,TotalCS) -> create_mem_info(Parent) -> Panel = wxPanel:new(Parent), - wxWindow:setBackgroundColour(Panel, {255,255,255}), Style = ?wxLC_REPORT bor ?wxLC_SINGLE_SEL bor ?wxLC_HRULES bor ?wxLC_VRULES, Grid = wxListCtrl:new(Panel, [{style, Style}]), Li = wxListItem:new(), diff --git a/lib/observer/src/observer_lib.erl b/lib/observer/src/observer_lib.erl index f0b8a004ec..5d5ac37ce9 100644 --- a/lib/observer/src/observer_lib.erl +++ b/lib/observer/src/observer_lib.erl @@ -122,7 +122,7 @@ display_yes_no_dialog(Str) -> %% display_info(Parent, [{Title, [{Label, Info}]}]) -> {Panel, Sizer, InfoFieldsToUpdate} display_info(Frame, Info) -> Panel = wxPanel:new(Frame), - wxWindow:setBackgroundColour(Panel, {255,255,255}), + wxWindow:setBackgroundStyle(Panel, ?wxBG_STYLE_SYSTEM), Sizer = wxBoxSizer:new(?wxVERTICAL), wxSizer:addSpacer(Sizer, 5), Add = fun(BoxInfo) -> @@ -201,22 +201,21 @@ update_info2([Scroll = {_, _, _}|Fs], [{_, NewInfo}|Rest]) -> update_scroll_boxes(Scroll, NewInfo), update_info2(Fs, Rest); update_info2([Field|Fs], [{_Str, {click, Value}}|Rest]) -> - wxTextCtrl:setValue(Field, to_str(Value)), + wxStaticText:setLabel(Field, to_str(Value)), update_info2(Fs, Rest); update_info2([Field|Fs], [{_Str, Value}|Rest]) -> - wxTextCtrl:setValue(Field, to_str(Value)), + wxStaticText:setLabel(Field, to_str(Value)), update_info2(Fs, Rest); update_info2([Field|Fs], [undefined|Rest]) -> - wxTextCtrl:setValue(Field, ""), + wxStaticText:setLabel(Field, ""), update_info2(Fs, Rest); update_info2([], []) -> ok. update_scroll_boxes({_, _, 0}, {_, []}) -> ok; update_scroll_boxes({Win, Sizer, _}, {Type, List}) -> [wxSizerItem:deleteWindows(Child) || Child <- wxSizer:getChildren(Sizer)], - BC = wxWindow:getBackgroundColour(Win), Cursor = wxCursor:new(?wxCURSOR_HAND), - add_entries(Type, List, Win, Sizer, BC, Cursor), + add_entries(Type, List, Win, Sizer, Cursor), wxCursor:destroy(Cursor), wxSizer:recalcSizes(Sizer), wxWindow:refresh(Win), @@ -379,25 +378,22 @@ add_box(Panel, OuterBox, Cursor, Title, Proportion, {Format, List}) -> wxScrolledWindow:setScrollbars(Scroll,1,1,0,0), ScrollSizer = wxBoxSizer:new(?wxVERTICAL), wxScrolledWindow:setSizer(Scroll, ScrollSizer), - BC = wxWindow:getBackgroundColour(Panel), - wxWindow:setBackgroundColour(Scroll,BC), - add_entries(Format, List, Scroll, ScrollSizer, BC, Cursor), + wxWindow:setBackgroundStyle(Scroll, ?wxBG_STYLE_SYSTEM), + add_entries(Format, List, Scroll, ScrollSizer, Cursor), wxSizer:add(Box,Scroll,[{proportion,1},{flag,?wxEXPAND}]), wxSizer:add(OuterBox,Box,[{proportion,Proportion},{flag,?wxEXPAND}]), {Scroll,ScrollSizer,length(List)}. -add_entries(click, List, Scroll, ScrollSizer, BC, Cursor) -> +add_entries(click, List, Scroll, ScrollSizer, Cursor) -> Add = fun(Link) -> TC = link_entry(Scroll, Link, Cursor), - wxWindow:setBackgroundColour(TC,BC), - wxSizer:add(ScrollSizer,TC,[{flag,?wxEXPAND}]) + wxWindow:setBackgroundStyle(TC, ?wxBG_STYLE_SYSTEM), + wxSizer:add(ScrollSizer,TC, [{flag,?wxEXPAND}]) end, [Add(Link) || Link <- List]; -add_entries(plain, List, Scroll, ScrollSizer, _, _) -> +add_entries(plain, List, Scroll, ScrollSizer, _) -> Add = fun(String) -> - TC = wxTextCtrl:new(Scroll, ?wxID_ANY, - [{style,?SINGLE_LINE_STYLE}, - {value,String}]), + TC = wxStaticText:new(Scroll, ?wxID_ANY, String), wxSizer:add(ScrollSizer,TC,[{flag,?wxEXPAND}]) end, [Add(String) || String <- List]. @@ -435,51 +431,44 @@ create_box(Panel, {scroll_boxes,Data}) -> wxSizer:layout(OuterBox), {OuterBox, Boxes}; -create_box(Panel, Data) -> +create_box(Parent, Data) -> {Title, Align, Info} = get_box_info(Data), - Box = wxStaticBoxSizer:new(?wxVERTICAL, Panel, [{label, Title}]), - LeftSize = get_max_size(Panel,Info), - LeftProportion = [{proportion,0}], - RightProportion = [{proportion,1}, {flag, Align bor ?wxEXPAND}], + Top = wxStaticBoxSizer:new(?wxVERTICAL, Parent, [{label, Title}]), + Panel = wxPanel:new(Parent), + Box = wxBoxSizer:new(?wxVERTICAL), + LeftSize = get_max_width(Panel,Info), + RightProportion = [{flag, Align bor ?wxEXPAND}], AddRow = fun({Desc0, Value0}) -> Desc = Desc0++":", Line = wxBoxSizer:new(?wxHORIZONTAL), - wxSizer:add(Line, - wxTextCtrl:new(Panel, ?wxID_ANY, - [{style,?SINGLE_LINE_STYLE}, - {size,LeftSize}, - {value,Desc}]), - LeftProportion), + Label = wxStaticText:new(Panel, ?wxID_ANY, Desc), + wxSizer:add(Line, 5, 0), + wxSizer:add(Line, Label), + wxSizer:setItemMinSize(Line, Label, LeftSize, -1), Field = case Value0 of {click,"unknown"} -> - wxTextCtrl:new(Panel, ?wxID_ANY, - [{style,?SINGLE_LINE_STYLE}, - {value,"unknown"}]); + wxStaticText:new(Panel, ?wxID_ANY,"unknown"); {click,Value} -> link_entry(Panel,Value); _ -> Value = to_str(Value0), - TCtrl = wxTextCtrl:new(Panel, ?wxID_ANY, - [{style,?SINGLE_LINE_STYLE}, - {value,Value}]), + TCtrl = wxStaticText:new(Panel, ?wxID_ANY,Value), length(Value) > 50 andalso wxWindow:setToolTip(TCtrl,wxToolTip:new(Value)), TCtrl end, wxSizer:add(Line, 10, 0), % space of size 10 horisontally wxSizer:add(Line, Field, RightProportion), - - {_,H,_,_} = wxTextCtrl:getTextExtent(Field,"Wj"), - wxTextCtrl:setMinSize(Field,{0,H}), - - wxSizer:add(Box, Line, [{proportion,0},{flag,?wxEXPAND}]), + wxSizer:add(Box, Line, [{proportion,1},{flag,?wxEXPAND}]), Field; (undefined) -> undefined end, InfoFields = [AddRow(Entry) || Entry <- Info], - {Box, InfoFields}. + wxWindow:setSizer(Panel, Box), + wxSizer:add(Top, Panel, [{proportion,1},{flag,?wxEXPAND}]), + {Top, InfoFields}. link_entry(Panel, Link) -> Cursor = wxCursor:new(?wxCURSOR_HAND), @@ -490,13 +479,12 @@ link_entry(Panel, Link, Cursor) -> link_entry2(Panel, to_link(Link), Cursor). link_entry2(Panel,{Target,Str},Cursor) -> - TC = wxTextCtrl:new(Panel, ?wxID_ANY, [{style, ?SINGLE_LINE_STYLE}]), - wxTextCtrl:setForegroundColour(TC,?wxBLUE), - wxTextCtrl:appendText(TC, Str), + TC = wxStaticText:new(Panel, ?wxID_ANY, Str), + wxWindow:setForegroundColour(TC,?wxBLUE), wxWindow:setCursor(TC, Cursor), - wxTextCtrl:connect(TC, left_down, [{userData,Target}]), - wxTextCtrl:connect(TC, enter_window), - wxTextCtrl:connect(TC, leave_window), + wxWindow:connect(TC, left_down, [{userData,Target}]), + wxWindow:connect(TC, enter_window), + wxWindow:connect(TC, leave_window), ToolTip = wxToolTip:new("Click to see properties for " ++ Str), wxWindow:setToolTip(TC, ToolTip), TC. @@ -521,23 +509,12 @@ html_window(Panel, Html) -> wxHtmlWindow:setPage(Win, Html), Win. -get_max_size(Panel,Info) -> - Txt = wxTextCtrl:new(Panel, ?wxID_ANY, []), - Size = get_max_size(Txt,Info,0,0), - wxTextCtrl:destroy(Txt), - Size. - -get_max_size(Txt,[{Desc,_}|Info],MaxX,MaxY) -> - {X,Y,_,_} = wxTextCtrl:getTextExtent(Txt,Desc++":"), - if X>MaxX -> - get_max_size(Txt,Info,X,Y); - true -> - get_max_size(Txt,Info,MaxX,MaxY) - end; -get_max_size(Txt,[undefined|Info],MaxX,MaxY) -> - get_max_size(Txt,Info,MaxX,MaxY); -get_max_size(_,[],X,_Y) -> - {X+2,-1}. +get_max_width(Parent,Info) -> + lists:foldl(fun({Desc,_}, Max) -> + {W, _, _, _} = wxWindow:getTextExtent(Parent, Desc), + max(W,Max); + (_, Max) -> Max + end, 0, Info). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% set_listctrl_col_size(LCtrl, Total) -> diff --git a/lib/observer/src/observer_perf_wx.erl b/lib/observer/src/observer_perf_wx.erl index 017f07d2c4..45af08026a 100644 --- a/lib/observer/src/observer_perf_wx.erl +++ b/lib/observer/src/observer_perf_wx.erl @@ -100,7 +100,7 @@ setup_graph_drawing(Panels) -> IsWindows = element(1, os:type()) =:= win32, IgnoreCB = {callback, fun(_,_) -> ok end}, Do = fun(#win{panel=Panel}) -> - wxWindow:setBackgroundColour(Panel, ?wxWHITE), + wxWindow:setBackgroundStyle(Panel, ?wxBG_STYLE_SYSTEM), wxPanel:connect(Panel, paint, [callback]), IsWindows andalso wxPanel:connect(Panel, erase_background, [IgnoreCB]) diff --git a/lib/observer/src/observer_procinfo.erl b/lib/observer/src/observer_procinfo.erl index 9d6aa84384..cff5fbb474 100644 --- a/lib/observer/src/observer_procinfo.erl +++ b/lib/observer/src/observer_procinfo.erl @@ -125,11 +125,11 @@ handle_event(#wx{event=#wxMouse{type=left_down}, userData=TargetPid}, State) -> {noreply, State}; handle_event(#wx{obj=Obj, event=#wxMouse{type=enter_window}}, State) -> - wxTextCtrl:setForegroundColour(Obj,{0,0,100,255}), + wxStaticText:setForegroundColour(Obj,{0,0,100,255}), {noreply, State}; handle_event(#wx{obj=Obj, event=#wxMouse{type=leave_window}}, State) -> - wxTextCtrl:setForegroundColour(Obj,?wxBLUE), + wxStaticText:setForegroundColour(Obj,?wxBLUE), {noreply, State}; handle_event(#wx{event=#wxHtmlLink{linkInfo=#wxHtmlLinkInfo{href=Href}}}, diff --git a/lib/runtime_tools/c_src/Makefile.in b/lib/runtime_tools/c_src/Makefile.in index 70b48daf97..4530a83aee 100644 --- a/lib/runtime_tools/c_src/Makefile.in +++ b/lib/runtime_tools/c_src/Makefile.in @@ -91,7 +91,7 @@ $(OBJDIR): $(LIBDIR): -@mkdir -p $(LIBDIR) -$(OBJDIR)/%$(TYPEMARKER).o: %.c +$(OBJDIR)/%$(TYPEMARKER).o: %.c dyntrace_lttng.h $(V_CC) -c -o $@ $(ALL_CFLAGS) $< $(LIBDIR)/%$(TYPEMARKER).@DED_EXT@: $(OBJDIR)/%$(TYPEMARKER).o diff --git a/lib/runtime_tools/c_src/dyntrace.c b/lib/runtime_tools/c_src/dyntrace.c index 0ef8eaf4d3..0178d95efb 100644 --- a/lib/runtime_tools/c_src/dyntrace.c +++ b/lib/runtime_tools/c_src/dyntrace.c @@ -29,7 +29,13 @@ #include "sys.h" #include "dtrace-wrapper.h" #if defined(USE_DYNAMIC_TRACE) && (defined(USE_DTRACE) || defined(USE_SYSTEMTAP)) -#define HAVE_USE_DTRACE 1 +# define HAVE_USE_DTRACE 1 +#endif +#if defined(USE_LTTNG) +# define HAVE_USE_LTTNG 1 +# define TRACEPOINT_DEFINE +# define TRACEPOINT_CREATE_PROBES +# include "dyntrace_lttng.h" #endif void dtrace_nifenv_str(ErlNifEnv *env, char *process_buf); @@ -60,11 +66,56 @@ static ERL_NIF_TERM user_trace_s1(ErlNifEnv* env, int argc, const ERL_NIF_TERM a static ERL_NIF_TERM user_trace_i4s4(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM user_trace_n(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); + +#ifdef HAVE_USE_LTTNG +static ERL_NIF_TERM trace_procs(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace_ports(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace_running_procs(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace_running_ports(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace_call(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace_send(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace_receive(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace_garbage_collection(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); + +static ERL_NIF_TERM enabled_procs(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled_ports(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled_running_procs(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled_running_ports(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled_call(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled_send(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled_receive(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled_garbage_collection(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +#endif + + static ErlNifFunc nif_funcs[] = { {"available", 0, available}, {"user_trace_s1", 1, user_trace_s1}, {"user_trace_i4s4", 9, user_trace_i4s4}, - {"user_trace_n", 10, user_trace_n} + {"user_trace_n", 10, user_trace_n}, +#ifdef HAVE_USE_LTTNG + {"trace_procs", 6, trace_procs}, + {"trace_ports", 6, trace_ports}, + {"trace_running_procs", 6, trace_running_procs}, + {"trace_running_ports", 6, trace_running_ports}, + {"trace_call", 6, trace_call}, + {"trace_send", 6, trace_send}, + {"trace_receive", 6, trace_receive}, + {"trace_garbage_collection", 6, trace_garbage_collection}, + {"enabled_procs", 3, enabled_procs}, + {"enabled_ports", 3, enabled_ports}, + {"enabled_running_procs", 3, enabled_running_procs}, + {"enabled_running_ports", 3, enabled_running_ports}, + {"enabled_call", 3, enabled_call}, + {"enabled_send", 3, enabled_send}, + {"enabled_receive", 3, enabled_receive}, + {"enabled_garbage_collection", 3, enabled_garbage_collection}, +#endif + {"enabled", 3, enabled}, + {"trace", 5, trace}, + {"trace", 6, trace} }; ERL_NIF_INIT(dyntrace, nif_funcs, load, NULL, NULL, NULL) @@ -76,6 +127,61 @@ static ERL_NIF_TERM atom_not_available; static ERL_NIF_TERM atom_badarg; static ERL_NIF_TERM atom_ok; +static ERL_NIF_TERM atom_trace; +static ERL_NIF_TERM atom_seq_trace; +static ERL_NIF_TERM atom_remove; +static ERL_NIF_TERM atom_discard; + +#ifdef HAVE_USE_LTTNG + +/* gc atoms */ + +static ERL_NIF_TERM atom_gc_minor_start; +static ERL_NIF_TERM atom_gc_minor_end; +static ERL_NIF_TERM atom_gc_major_start; +static ERL_NIF_TERM atom_gc_major_end; + +static ERL_NIF_TERM atom_old_heap_block_size; /* for debug */ +static ERL_NIF_TERM atom_heap_block_size; /* for debug */ + +/* process 'procs' */ + +static ERL_NIF_TERM atom_spawn; +static ERL_NIF_TERM atom_exit; +static ERL_NIF_TERM atom_register; +static ERL_NIF_TERM atom_unregister; +static ERL_NIF_TERM atom_link; +static ERL_NIF_TERM atom_unlink; +static ERL_NIF_TERM atom_getting_linked; +static ERL_NIF_TERM atom_getting_unlinked; + +/* process 'running' and 'exiting' */ + +static ERL_NIF_TERM atom_in; +static ERL_NIF_TERM atom_out; +static ERL_NIF_TERM atom_in_exiting; +static ERL_NIF_TERM atom_out_exiting; +static ERL_NIF_TERM atom_out_exited; + +/* process messages 'send' and 'receive' */ + +static ERL_NIF_TERM atom_send; +static ERL_NIF_TERM atom_receive; +static ERL_NIF_TERM atom_send_to_non_existing_process; + +/* ports 'ports' */ + +static ERL_NIF_TERM atom_open; +static ERL_NIF_TERM atom_closed; + +/* 'call' */ + +static ERL_NIF_TERM atom_call; +static ERL_NIF_TERM atom_return_from; +static ERL_NIF_TERM atom_return_to; +static ERL_NIF_TERM atom_exception_from; +#endif + static int load(ErlNifEnv* env, void** priv_data, ERL_NIF_TERM load_info) { atom_true = enif_make_atom(env,"true"); @@ -85,6 +191,61 @@ static int load(ErlNifEnv* env, void** priv_data, ERL_NIF_TERM load_info) atom_badarg = enif_make_atom(env,"badarg"); atom_ok = enif_make_atom(env,"ok"); + atom_trace = enif_make_atom(env,"trace"); + atom_seq_trace = enif_make_atom(env,"seq_trace"); + atom_remove = enif_make_atom(env,"remove"); + atom_discard = enif_make_atom(env,"discard"); + +#ifdef HAVE_USE_LTTNG + + /* gc */ + + atom_gc_minor_start = enif_make_atom(env,"gc_minor_start"); + atom_gc_minor_end = enif_make_atom(env,"gc_minor_end"); + atom_gc_major_start = enif_make_atom(env,"gc_major_start"); + atom_gc_major_end = enif_make_atom(env,"gc_major_end"); + + atom_old_heap_block_size = enif_make_atom(env,"old_heap_block_size"); + atom_heap_block_size = enif_make_atom(env,"heap_block_size"); + + /* process 'proc' */ + + atom_spawn = enif_make_atom(env,"spawn"); + atom_exit = enif_make_atom(env,"exit"); + atom_register = enif_make_atom(env,"register"); + atom_unregister = enif_make_atom(env,"unregister"); + atom_link = enif_make_atom(env,"link"); + atom_unlink = enif_make_atom(env,"unlink"); + atom_getting_unlinked = enif_make_atom(env,"getting_unlinked"); + atom_getting_linked = enif_make_atom(env,"getting_linked"); + + /* process 'running' and 'exiting' */ + + atom_in = enif_make_atom(env,"in"); + atom_out = enif_make_atom(env,"out"); + atom_in_exiting = enif_make_atom(env,"in_exiting"); + atom_out_exiting = enif_make_atom(env,"out_exiting"); + atom_out_exited = enif_make_atom(env,"out_exited"); + + /* process messages 'send' and 'receive' */ + + atom_send = enif_make_atom(env,"send"); + atom_receive = enif_make_atom(env,"receive"); + atom_send_to_non_existing_process = enif_make_atom(env,"send_to_non_existing_process"); + + /* ports 'ports' */ + + atom_open = enif_make_atom(env,"open"); + atom_closed = enif_make_atom(env,"closed"); + + /* 'call' */ + + atom_call = enif_make_atom(env,"call"); + atom_return_from = enif_make_atom(env,"return_from"); + atom_return_to = enif_make_atom(env,"return_to"); + atom_exception_from = enif_make_atom(env,"exception_from"); +#endif + return 0; } @@ -123,3 +284,442 @@ static ERL_NIF_TERM user_trace_n(ErlNifEnv* env, int argc, const ERL_NIF_TERM ar return atom_error; #endif } + +static ERL_NIF_TERM enabled(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ +#ifdef HAVE_USE_LTTNG + ASSERT(argc == 3); + return atom_trace; +#endif + return atom_remove; +} + +static ERL_NIF_TERM trace(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + return atom_ok; +} + +#ifdef HAVE_USE_LTTNG +static ERL_NIF_TERM enabled_garbage_collection(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + ASSERT(argc == 3); + + if (argv[0] == atom_gc_minor_start && LTTNG_ENABLED(gc_minor_start)) { + return atom_trace; + } else if (argv[0] == atom_gc_minor_end && LTTNG_ENABLED(gc_minor_end)) { + return atom_trace; + } else if (argv[0] == atom_gc_major_start && LTTNG_ENABLED(gc_major_start)) { + return atom_trace; + } else if (argv[0] == atom_gc_major_end && LTTNG_ENABLED(gc_major_end)) { + return atom_trace; + } + + return atom_discard; +} + +static ERL_NIF_TERM trace_garbage_collection(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + lttng_decl_procbuf(pid); + ERL_NIF_TERM gci, tup; + const ERL_NIF_TERM *vals; + int arity; + unsigned long ohbsz, nhbsz, size; + + ASSERT(argc == 6); + + /* Assume gc info order does not change */ + gci = argv[3]; + + /* get reclaimed or need */ + enif_get_list_cell(env, gci, &tup, &gci); + enif_get_tuple(env, tup, &arity, &vals); + ASSERT(arity == 2); + enif_get_ulong(env, vals[1], &size); + + /* get old heap block size */ + enif_get_list_cell(env, gci, &tup, &gci); + enif_get_tuple(env, tup, &arity, &vals); + ASSERT(arity == 2); + ASSERT(vals[0] == atom_old_heap_block_size); + enif_get_ulong(env, vals[1], &ohbsz); + + /* get new heap block size */ + enif_get_list_cell(env, gci, &tup, &gci); + enif_get_tuple(env, tup, &arity, &vals); + ASSERT(arity == 2); + ASSERT(vals[0] == atom_heap_block_size); + enif_get_ulong(env, vals[1], &nhbsz); + + lttng_pid_to_str(argv[2], pid); + + if (argv[0] == atom_gc_minor_start) { + LTTNG4(gc_minor_start, pid, size, nhbsz, ohbsz); + } else if (argv[0] == atom_gc_minor_end) { + LTTNG4(gc_minor_end, pid, size, nhbsz, ohbsz); + } else if (argv[0] == atom_gc_major_start) { + LTTNG4(gc_major_start, pid, size, nhbsz, ohbsz); + } else if (argv[0] == atom_gc_major_end) { + LTTNG4(gc_major_end, pid, size, nhbsz, ohbsz); + } + return atom_ok; +} + +static ERL_NIF_TERM enabled_call(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + ASSERT(argc == 3); + + if (argv[0] == atom_call && LTTNG_ENABLED(function_call)) + return atom_trace; + else if (argv[0] == atom_return_from && LTTNG_ENABLED(function_return)) + return atom_trace; + else if (argv[0] == atom_exception_from && LTTNG_ENABLED(function_exception)) + return atom_trace; + + return atom_discard; +} + +static ERL_NIF_TERM trace_call(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + lttng_decl_procbuf(pid); + unsigned int len; + char undef[] = "undefined"; + + lttng_pid_to_str(argv[2], pid); + + if (argv[0] == atom_call) { + const ERL_NIF_TERM* tuple; + int arity; + lttng_decl_mfabuf(mfa); + + if (enif_get_tuple(env, argv[3], &arity, &tuple)) { + if (enif_is_list(env, tuple[2])) { + enif_get_list_length(env, tuple[2], &len); + } else { + enif_get_uint(env, tuple[2], &len); + } + lttng_mfa_to_str(tuple[0], tuple[1], len, mfa); + LTTNG3(function_call, pid, mfa, 0); + } else { + LTTNG3(function_call, pid, undef, 0); + } + } else if (argv[0] == atom_return_from) { + const ERL_NIF_TERM* tuple; + int arity; + lttng_decl_mfabuf(mfa); + + if (enif_get_tuple(env, argv[3], &arity, &tuple)) { + enif_get_uint(env, tuple[2], &len); + lttng_mfa_to_str(tuple[0], tuple[1], len, mfa); + LTTNG3(function_return, pid, mfa, 0); + } else { + LTTNG3(function_return, pid, undef, 0); + } + } else if (argv[0] == atom_return_to) { + const ERL_NIF_TERM* tuple; + int arity; + lttng_decl_mfabuf(mfa); + + if (enif_get_tuple(env, argv[3], &arity, &tuple)) { + enif_get_uint(env, tuple[2], &len); + lttng_mfa_to_str(tuple[0], tuple[1], len, mfa); + LTTNG3(function_return, pid, mfa, 0); + } else { + LTTNG3(function_return, pid, undef, 0); + } + } else if (argv[0] == atom_exception_from) { + const ERL_NIF_TERM* tuple; + int arity; + lttng_decl_mfabuf(mfa); + char class[LTTNG_BUFFER_SZ]; + + enif_get_tuple(env, argv[4], &arity, &tuple); + erts_snprintf(class, LTTNG_BUFFER_SZ, "%T", tuple[0]); + + if (enif_get_tuple(env, argv[3], &arity, &tuple)) { + enif_get_uint(env, tuple[2], &len); + lttng_mfa_to_str(tuple[0], tuple[1], len, mfa); + LTTNG3(function_exception, pid, mfa, class); + } else { + LTTNG3(function_exception, pid, undef, class); + } + } + return atom_ok; +} + +static ERL_NIF_TERM enabled_send(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + ASSERT(argc == 3); + if (LTTNG_ENABLED(message_send)) + return atom_trace; + + return atom_discard; +} + +static ERL_NIF_TERM trace_send(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + lttng_decl_procbuf(pid); + lttng_pid_to_str(argv[2], pid); + + if (argv[0] == atom_send) { + lttng_decl_procbuf(to); + char msg[LTTNG_BUFFER_SZ]; + + lttng_pid_to_str(argv[4], to); + erts_snprintf(msg, LTTNG_BUFFER_SZ, "%T", argv[3]); + + LTTNG3(message_send, pid, to, msg); + } else if (argv[0] == atom_send_to_non_existing_process) { + lttng_decl_procbuf(to); + char msg[LTTNG_BUFFER_SZ]; + + lttng_pid_to_str(argv[4], to); + erts_snprintf(msg, LTTNG_BUFFER_SZ, "%T", argv[3]); + /* mark it as non existing ? */ + + LTTNG3(message_send, pid, to, msg); + } + return atom_ok; +} + +static ERL_NIF_TERM enabled_receive(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + if (LTTNG_ENABLED(message_receive)) + return atom_trace; + + return atom_discard; +} + +static ERL_NIF_TERM trace_receive(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + if (argv[0] == atom_receive) { + lttng_decl_procbuf(pid); + char msg[LTTNG_BUFFER_SZ]; + + lttng_pid_to_str(argv[2], pid); + erts_snprintf(msg, LTTNG_BUFFER_SZ, "%T", argv[3]); + + LTTNG2(message_receive, pid, msg); + } + return atom_ok; +} + +static ERL_NIF_TERM enabled_procs(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + ASSERT(argc == 3); + + if (argv[0] == atom_spawn && LTTNG_ENABLED(process_spawn)) { + return atom_trace; + } else if (argv[0] == atom_register && LTTNG_ENABLED(process_register)) { + return atom_trace; + } else if (argv[0] == atom_unregister && LTTNG_ENABLED(process_register)) { + return atom_trace; + } else if (argv[0] == atom_link && LTTNG_ENABLED(process_link)) { + return atom_trace; + } else if (argv[0] == atom_unlink && LTTNG_ENABLED(process_link)) { + return atom_trace; + } else if (argv[0] == atom_getting_linked && LTTNG_ENABLED(process_link)) { + return atom_trace; + } else if (argv[0] == atom_getting_unlinked && LTTNG_ENABLED(process_link)) { + return atom_trace; + } else if (argv[0] == atom_exit && LTTNG_ENABLED(process_exit)) { + return atom_trace; + } + + return atom_discard; +} + +static ERL_NIF_TERM trace_procs(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + lttng_decl_procbuf(pid); + lttng_decl_procbuf(to); + + lttng_pid_to_str(argv[2], pid); + + /* spawn */ + if (argv[0] == atom_spawn) { + char undef[] = "undefined"; + const ERL_NIF_TERM* tuple; + int arity; + unsigned int len; + lttng_decl_mfabuf(mfa); + + lttng_pid_to_str(argv[3], to); + + if (enif_get_tuple(env, argv[4], &arity, &tuple)) { + if (enif_is_list(env, tuple[2])) { + enif_get_list_length(env, tuple[2], &len); + } else { + enif_get_uint(env, tuple[2], &len); + } + lttng_mfa_to_str(tuple[0], tuple[1], len, mfa); + LTTNG3(process_spawn, to, pid, mfa); + } else { + LTTNG3(process_spawn, to, pid, undef); + } + + /* register */ + } else if (argv[0] == atom_register) { + char name[LTTNG_BUFFER_SZ]; + erts_snprintf(name, LTTNG_BUFFER_SZ, "%T", argv[3]); + LTTNG3(process_register, pid, name, "register"); + } else if (argv[0] == atom_unregister) { + char name[LTTNG_BUFFER_SZ]; + erts_snprintf(name, LTTNG_BUFFER_SZ, "%T", argv[3]); + LTTNG3(process_register, pid, name, "unregister"); + /* link */ + } else if (argv[0] == atom_link) { + lttng_pid_to_str(argv[3], to); + LTTNG3(process_link, pid, to, "link"); + } else if (argv[0] == atom_unlink) { + lttng_pid_to_str(argv[3], to); + LTTNG3(process_link, pid, to, "unlink"); + } else if (argv[0] == atom_getting_linked) { + lttng_pid_to_str(argv[3], to); + LTTNG3(process_link, to, pid, "link"); + } else if (argv[0] == atom_getting_unlinked) { + lttng_pid_to_str(argv[3], to); + LTTNG3(process_link, to, pid, "unlink"); + /* exit */ + } else if (argv[0] == atom_exit) { + char reason[LTTNG_BUFFER_SZ]; + erts_snprintf(reason, LTTNG_BUFFER_SZ, "%T", argv[3]); + LTTNG2(process_exit, pid, reason); + } + return atom_ok; +} + +static ERL_NIF_TERM enabled_ports(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + ASSERT(argc == 3); + + if (argv[0] == atom_open && LTTNG_ENABLED(port_open)) { + return atom_trace; + } else if (argv[0] == atom_link && LTTNG_ENABLED(port_link)) { + return atom_trace; + } else if (argv[0] == atom_unlink && LTTNG_ENABLED(port_link)) { + return atom_trace; + } else if (argv[0] == atom_getting_linked && LTTNG_ENABLED(port_link)) { + return atom_trace; + } else if (argv[0] == atom_getting_unlinked && LTTNG_ENABLED(port_link)) { + return atom_trace; + } else if (argv[0] == atom_closed && LTTNG_ENABLED(port_exit)) { + return atom_trace; + } + + return atom_discard; +} + +static ERL_NIF_TERM trace_ports(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + lttng_decl_portbuf(port); + lttng_decl_procbuf(to); + + lttng_portid_to_str(argv[2], port); + + /* open and closed */ + if (argv[0] == atom_open) { + char driver[LTTNG_BUFFER_SZ]; + lttng_decl_procbuf(pid); + lttng_pid_to_str(argv[3], pid); + + erts_snprintf(driver, LTTNG_BUFFER_SZ, "%T", argv[4]); + LTTNG3(port_open, pid, driver, port); + } else if (argv[0] == atom_closed) { + char reason[LTTNG_BUFFER_SZ]; + erts_snprintf(reason, LTTNG_BUFFER_SZ, "%T", argv[3]); + + LTTNG2(port_exit, port, reason); + /* link */ + } else if (argv[0] == atom_link) { + lttng_pid_to_str(argv[3], to); + LTTNG3(port_link, port, to, "link"); + } else if (argv[0] == atom_unlink) { + lttng_pid_to_str(argv[3], to); + LTTNG3(port_link, port, to, "unlink"); + } else if (argv[0] == atom_getting_linked) { + lttng_pid_to_str(argv[3], to); + LTTNG3(port_link, to, port, "link"); + } else if (argv[0] == atom_getting_unlinked) { + lttng_pid_to_str(argv[3], to); + LTTNG3(port_link, to, port, "unlink"); + } + return atom_ok; +} + +static ERL_NIF_TERM enabled_running_procs(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + ASSERT(argc == 3); + + if (LTTNG_ENABLED(process_scheduled)) + return atom_trace; + + return atom_discard; +} + +static ERL_NIF_TERM trace_running_procs(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + lttng_decl_procbuf(pid); + const ERL_NIF_TERM* tuple; + char *mfastr = "undefined"; + int arity; + lttng_decl_mfabuf(mfa); + + lttng_pid_to_str(argv[2], pid); + + if (enif_get_tuple(env, argv[3], &arity, &tuple)) { + int val; + enif_get_int(env, tuple[2], &val); + lttng_mfa_to_str(tuple[0], tuple[1], val, mfa); + mfastr = mfa; + } + /* running processes */ + if (argv[0] == atom_in) { + LTTNG3(process_scheduled, pid, mfastr, "in"); + } else if (argv[0] == atom_out) { + LTTNG3(process_scheduled, pid, mfastr, "out"); + /* exiting */ + } else if (argv[0] == atom_in_exiting) { + LTTNG3(process_scheduled, pid, mfastr, "in_exiting"); + } else if (argv[0] == atom_out_exiting) { + LTTNG3(process_scheduled, pid, mfastr, "out_exiting"); + } else if (argv[0] == atom_out_exited) { + LTTNG3(process_scheduled, pid, mfastr, "out_exited"); + } + + return atom_ok; +} + +static ERL_NIF_TERM enabled_running_ports(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + ASSERT(argc == 3); + + if (LTTNG_ENABLED(port_scheduled)) + return atom_trace; + + return atom_discard; +} + +static ERL_NIF_TERM trace_running_ports(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + lttng_decl_procbuf(pid); + lttng_decl_mfabuf(where); + + lttng_portid_to_str(argv[2], pid); + erts_snprintf(where, LTTNG_BUFFER_SZ, "%T", argv[3]); + + /* running ports */ + if (argv[0] == atom_in) { + LTTNG3(port_scheduled, pid, where, "in"); + } else if (argv[0] == atom_out) { + LTTNG3(port_scheduled, pid, where, "out"); + /* exiting */ + } else if (argv[0] == atom_in_exiting) { + LTTNG3(port_scheduled, pid, where, "in_exiting"); + } else if (argv[0] == atom_out_exiting) { + LTTNG3(port_scheduled, pid, where, "out_exiting"); + } else if (argv[0] == atom_out_exited) { + LTTNG3(port_scheduled, pid, where, "out_exited"); + } + return atom_ok; +} +#endif diff --git a/lib/runtime_tools/c_src/dyntrace_lttng.h b/lib/runtime_tools/c_src/dyntrace_lttng.h new file mode 100644 index 0000000000..3550a1cab5 --- /dev/null +++ b/lib/runtime_tools/c_src/dyntrace_lttng.h @@ -0,0 +1,367 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2016. All Rights Reserved. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * + * %CopyrightEnd% + */ + +#undef TRACEPOINT_PROVIDER +#define TRACEPOINT_PROVIDER com_ericsson_dyntrace + +#if !defined(DYNTRACE_LTTNG_H) || defined(TRACEPOINT_HEADER_MULTI_READ) +#define DYNTRACE_LTTNG_H + +#include <lttng/tracepoint.h> + +#define LTTNG1(Name, Arg1) \ + tracepoint(com_ericsson_dyntrace, Name, (Arg1)) + +#define LTTNG2(Name, Arg1, Arg2) \ + tracepoint(com_ericsson_dyntrace, Name, (Arg1), (Arg2)) + +#define LTTNG3(Name, Arg1, Arg2, Arg3) \ + tracepoint(com_ericsson_dyntrace, Name, (Arg1), (Arg2), (Arg3)) + +#define LTTNG4(Name, Arg1, Arg2, Arg3, Arg4) \ + tracepoint(com_ericsson_dyntrace, Name, (Arg1), (Arg2), (Arg3), (Arg4)) + +#define LTTNG5(Name, Arg1, Arg2, Arg3, Arg4, Arg5) \ + tracepoint(com_ericsson_dyntrace, Name, (Arg1), (Arg2), (Arg3), (Arg4), (Arg5)) + +#define LTTNG_ENABLED(Name) \ + tracepoint_enabled(com_ericsson_dyntrace, Name) + +#define LTTNG_BUFFER_SZ (256) +#define LTTNG_PROC_BUFFER_SZ (16) +#define LTTNG_PORT_BUFFER_SZ (20) +#define LTTNG_MFA_BUFFER_SZ (256) + +#define lttng_decl_procbuf(Name) \ + char Name[LTTNG_PROC_BUFFER_SZ] + +#define lttng_decl_portbuf(Name) \ + char Name[LTTNG_PORT_BUFFER_SZ] + +#define lttng_decl_mfabuf(Name) \ + char Name[LTTNG_MFA_BUFFER_SZ] + +#define lttng_pid_to_str(pid, name) \ + erts_snprintf(name, LTTNG_PROC_BUFFER_SZ, "%T", (pid)) + +#define lttng_portid_to_str(pid, name) \ + erts_snprintf(name, LTTNG_PORT_BUFFER_SZ, "%T", (pid)) + +#define lttng_proc_to_str(p, name) \ + lttng_pid_to_str(((p) ? (p)->common.id : ERTS_INVALID_PID), name) + +#define lttng_port_to_str(p, name) \ + lttng_portid_to_str(((p) ? (p)->common.id : ERTS_INVALID_PORT), name) + +#define lttng_mfa_to_str(m,f,a, Name) \ + erts_snprintf(Name, LTTNG_MFA_BUFFER_SZ, "%T:%T/%lu", (Eterm)(m), (Eterm)(f), (Uint)(a)) + +/* Process scheduling */ + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + process_spawn, + TP_ARGS( + char*, p, + char*, parent, + char*, mfa + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_string(parent, parent) + ctf_string(entry, mfa) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + process_link, + TP_ARGS( + char*, from, + char*, to, + char*, type + ), + TP_FIELDS( + ctf_string(from, from) + ctf_string(to, to) + ctf_string(type, type) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + process_exit, + TP_ARGS( + char*, p, + char*, reason + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_string(reason, reason) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + process_register, + TP_ARGS( + char*, pid, + char*, name, + char*, type + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(name, name) + ctf_string(type, type) + ) +) + +/* Scheduled */ + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + process_scheduled, + TP_ARGS( + char*, p, + char*, mfa, + char*, type + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_string(entry, mfa) + ctf_string(type, type) + ) +) + +/* Ports */ + + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + port_open, + TP_ARGS( + char*, pid, + char*, driver, + char*, port + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(driver, driver) + ctf_string(port, port) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + port_exit, + TP_ARGS( + char*, port, + char*, reason + ), + TP_FIELDS( + ctf_string(port, port) + ctf_string(reason, reason) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + port_link, + TP_ARGS( + char*, from, + char*, to, + char*, type + ), + TP_FIELDS( + ctf_string(from, from) + ctf_string(to, to) + ctf_string(type, type) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + port_scheduled, + TP_ARGS( + char*, p, + char*, op, + char*, type + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_string(entry, op) + ctf_string(type, type) + ) +) + +/* Call tracing */ + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + function_call, + TP_ARGS( + char*, pid, + char*, mfa, + unsigned int, depth + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(entry, mfa) + ctf_integer(unsigned int, depth, depth) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + function_return, + TP_ARGS( + char*, pid, + char*, mfa, + unsigned int, depth + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(entry, mfa) + ctf_integer(unsigned int, depth, depth) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + function_exception, + TP_ARGS( + char*, pid, + char*, mfa, + char*, type + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(entry, mfa) + ctf_string(class, type) + ) +) + +/* Process messages */ + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + message_send, + TP_ARGS( + char*, sender, + char*, receiver, + char*, msg + ), + TP_FIELDS( + ctf_string(from, sender) + ctf_string(to, receiver) + ctf_string(message, msg) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + message_receive, + TP_ARGS( + char*, receiver, + char*, msg + ), + TP_FIELDS( + ctf_string(to, receiver) + ctf_string(message, msg) + ) +) + +/* Process Memory */ + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + gc_minor_start, + TP_ARGS( + char*, p, + unsigned long, need, + unsigned long, nh, + unsigned long, oh + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_integer(unsigned long, need, need) + ctf_integer(unsigned long, heap, nh) + ctf_integer(unsigned long, old_heap, oh) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + gc_minor_end, + TP_ARGS( + char*, p, + unsigned long, reclaimed, + unsigned long, nh, + unsigned long, oh + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_integer(unsigned long, reclaimed, reclaimed) + ctf_integer(unsigned long, heap, nh) + ctf_integer(unsigned long, old_heap, oh) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + gc_major_start, + TP_ARGS( + char*, p, + unsigned long, need, + unsigned long, nh, + unsigned long, oh + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_integer(unsigned long, need, need) + ctf_integer(unsigned long, heap, nh) + ctf_integer(unsigned long, old_heap, oh) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + gc_major_end, + TP_ARGS( + char*, p, + unsigned long, reclaimed, + unsigned long, nh, + unsigned long, oh + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_integer(unsigned long, reclaimed, reclaimed) + ctf_integer(unsigned long, heap, nh) + ctf_integer(unsigned long, old_heap, oh) + ) +) + +#endif /* DYNTRACE_LTTNG_H */ + +#undef TRACEPOINT_INCLUDE +#define TRACEPOINT_INCLUDE "./dyntrace_lttng.h" + +/* This part must be outside protection */ +#include <lttng/tracepoint-event.h> diff --git a/lib/runtime_tools/doc/src/LTTng.xml b/lib/runtime_tools/doc/src/LTTng.xml new file mode 100644 index 0000000000..eab1848e88 --- /dev/null +++ b/lib/runtime_tools/doc/src/LTTng.xml @@ -0,0 +1,245 @@ +<?xml version="1.0" encoding="utf8" ?> +<!DOCTYPE chapter SYSTEM "chapter.dtd"> +<chapter> + <header> + <copyright> + <year>2016</year><year>2016</year> + <holder>Ericsson AB. All Rights Reserved.</holder> + </copyright> + <legalnotice> + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + </legalnotice> + + <title>LTTng and Erlang/OTP</title> + <prepared></prepared> + <responsible></responsible> + <docno></docno> + <approved></approved> + <checked></checked> + <date>2016-04-27</date> + <rev></rev> + <file>LTTng.xml</file> + </header> + + <section> + <title>Introduction</title> + <p>The Linux Trace Toolkit: next generation is an open source system software package + for correlated tracing of the Linux kernel, user applications and libraries. </p> + <p>For more information, please visit <url href="http://lttng.org">http://lttng.org</url></p> + </section> + + <section> + <title>Building Erlang/OTP with LTTng support</title> + <p> + Configure and build Erlang with LTTng support: + </p> + <p>For LTTng to work properly with Erlang/OTP you need + the following packages installed:</p> + + <list type="bulleted"> + <item><p>LTTng-tools: a command line interface to control tracing sessions.</p></item> + <item><p>LTTng-UST: user space tracing library.</p></item> + </list> + + <p>On Ubuntu this can be installed via <c>aptitude</c>:</p> + + <code type="none">$ sudo aptitude install lttng-tools liblttng-ust-dev</code> + <p>See <url href="http://lttng.org/docs/#doc-installing-lttng">Installing LTTng</url> + for more information on how to install LTTng on your system.</p> + + <p>After LTTng is properly installed on the system Erlang/OTP can be built with LTTng support.</p> + + +<code type="none">$ ./configure --with-dynamic-trace=lttng +$ make </code> + </section> + + <section> + <title>Dyntrace Tracepoints</title> + <p>All tracepoints are in the domain of <c>com_ericsson_dyntrace</c></p> + <p>All Erlang types are the string equivalent in LTTng.</p> + + <p><em>process_spawn</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>parent : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>entry : string</c> :: Code Location. Ex. <c>"lists:sort/1"</c></item> + </list> + <p>Example:</p> + <p><code type="none">process_spawn: { cpu_id = 3 }, { pid = "<0.131.0>", parent = "<0.130.0>", entry = "erlang:apply/2" }</code></p> + + <p><em>process_link</em></p> + <list type="bulleted"> + <item><c>to : string</c> :: Process ID or Port ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>from : string</c> :: Process ID or Port ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>type : string</c> :: <c>"link" | "unlink"</c></item> + </list> + <p>Example:</p> + <p><code type="none">process_link: { cpu_id = 3 }, { from = "<0.130.0>", to = "<0.131.0>", type = "link" }</code></p> + + + <p><em>process_exit</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>reason : string</c> :: Exit reason. Ex. <c>"normal"</c></item> + </list> + <p>Example:</p> + <p><code type="none">process_exit: { cpu_id = 3 }, { pid = "<0.130.0>", reason = "normal" }</code></p> + + <p><em>process_register</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>name : string</c> :: Registered name. Ex. <c>"error_logger"</c></item> + <item><c>type : string</c> :: <c>"register" | "unregister"</c></item> + </list> + <p>Example:</p> + <p><code type="none">process_register: { cpu_id = 0 }, { pid = "<0.128.0>", name = "dyntrace_lttng_SUITE" type = "register" }</code></p> + + <p><em>process_scheduled</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>entry : string</c> :: Code Location. Ex. <c>"lists:sort/1"</c></item> + <item><c>type : string</c> :: <c>"in" | "out" | "in_exiting" | "out_exiting" | "out_exited"</c></item> + </list> + + <p>Example:</p> + <p><code type="none">process_scheduled: { cpu_id = 0 }, { pid = "<0.136.0>", entry = "erlang:apply/2", type = "in" }</code></p> + + + <p><em>port_open</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> + </list> + + <p>Example:</p> + <p><code type="none">port_open: { cpu_id = 5 }, { pid = "<0.131.0>", driver = "'/bin/sh -s unix:cmd'", port = "#Port<0.1887>" }</code></p> + + <p><em>port_exit</em></p> + <list type="bulleted"> + <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> + <item><c>reason : string</c> :: Exit reason. Ex. <c>"normal"</c></item> + </list> + <p>Example:</p> + <p><code type="none">port_exit: { cpu_id = 5 }, { port = "#Port<0.1887>", reason = "normal" }</code></p> + + <p><em>port_link</em></p> + <list type="bulleted"> + <item><c>to : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>from : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>type : string</c> :: <c>"link" | "unlink"</c></item> + </list> + <p>Example:</p> + <p><code type="none">port_link: { cpu_id = 5 }, { from = "#Port<0.1887>", to = "<0.131.0>", type = "unlink" }</code></p> + + <p><em>port_scheduled</em></p> + <list type="bulleted"> + <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> + <item><c>entry : string</c> :: Callback. Ex. <c>"open"</c></item> + <item><c>type : string</c> :: <c>"in" | "out" | "in_exiting" | "out_exiting" | "out_exited"</c></item> + </list> + + <p>Example:</p> + <p><code type="none">port_scheduled: { cpu_id = 5 }, { pid = "#Port<0.1905>", entry = "close", type = "out" }</code></p> + + <p><em>function_call</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>entry : string</c> :: Code Location. Ex. <c>"lists:sort/1"</c></item> + <item><c>depth : integer</c> :: Stack depth. Ex. <c>0</c></item> + </list> + <p>Example:</p> + <p><code type="none">function_call: { cpu_id = 5 }, { pid = "<0.145.0>", entry = "dyntrace_lttng_SUITE:'-t_call/1-fun-1-'/0", depth = 0 }</code></p> + + <p><em>function_return</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>entry : string</c> :: Code Location. Ex. <c>"lists:sort/1"</c></item> + <item><c>depth : integer</c> :: Stack depth. Ex. <c>0</c></item> + </list> + <p>Example:</p> + <p><code type="none">function_return: { cpu_id = 5 }, { pid = "<0.145.0>", entry = "dyntrace_lttng_SUITE:waiter/0", depth = 0 }</code></p> + + <p><em>function_exception</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>entry : string</c> :: Code Location. Ex. <c>"lists:sort/1"</c></item> + <item><c>class : string</c> :: Error reason. Ex. <c>"error"</c></item> + </list> + <p>Example:</p> + <p><code type="none">function_exception: { cpu_id = 5 }, { pid = "<0.144.0>", entry = "t:call_exc/1", class = "error" }</code></p> + + <p><em>message_send</em></p> + <list type="bulleted"> + <item><c>from : string</c> :: Process ID or Port ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>to : string</c> :: Process ID or Port ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>message : string</c> :: Message sent. Ex. <c>"{<0.162.0>,ok}"</c></item> + </list> + <p>Example:</p> + <p><code type="none">message_send: { cpu_id = 3 }, { from = "#Port<0.1938>", to = "<0.160.0>", message = "{#Port<0.1938>,eof}" }</code></p> + + <p><em>message_receive</em></p> + <list type="bulleted"> + <item><c>to : string</c> :: Process ID or Port ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>message : string</c> :: Message received. Ex. <c>"{<0.162.0>,ok}"</c></item> + </list> + <p>Example:</p> + <p><code type="none">message_receive: { cpu_id = 7 }, { to = "<0.167.0>", message = "{<0.165.0>,ok}" }</code></p> + + <p><em>gc_minor_start</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>need : integer</c> :: Heap need. Ex. <c>2</c></item> + <item><c>heap : integer</c> :: Young heap word size. Ex. <c>233</c></item> + <item><c>old_heap : integer</c> :: Old heap word size. Ex. <c>233</c></item> + </list> + <p>Example:</p> + <p><code type="none">gc_minor_start: { cpu_id = 0 }, { pid = "<0.172.0>", need = 0, heap = 610, old_heap = 0 }</code></p> + + <p><em>gc_minor_end</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>reclaimed : integer</c> :: Heap reclaimed. Ex. <c>2</c></item> + <item><c>heap : integer</c> :: Young heap word size. Ex. <c>233</c></item> + <item><c>old_heap : integer</c> :: Old heap word size. Ex. <c>233</c></item> + </list> + <p>Example:</p> + <p><code type="none">gc_minor_end: { cpu_id = 0 }, { pid = "<0.172.0>", reclaimed = 120, heap = 1598, old_heap = 1598 }</code></p> + + <p><em>gc_major_start</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>need : integer</c> :: Heap need. Ex. <c>2</c></item> + <item><c>heap : integer</c> :: Young heap word size. Ex. <c>233</c></item> + <item><c>old_heap : integer</c> :: Old heap word size. Ex. <c>233</c></item> + </list> + <p>Example:</p> + <p><code type="none">gc_major_start: { cpu_id = 0 }, { pid = "<0.172.0>", need = 8, heap = 2586, old_heap = 1598 }</code></p> + + <p><em>gc_major_end</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>reclaimed : integer</c> :: Heap reclaimed. Ex. <c>2</c></item> + <item><c>heap : integer</c> :: Young heap word size. Ex. <c>233</c></item> + <item><c>old_heap : integer</c> :: Old heap word size. Ex. <c>233</c></item> + </list> + <p>Example:</p> + <p><code type="none">gc_major_end: { cpu_id = 0 }, { pid = "<0.172.0>", reclaimed = 240, heap = 4185, old_heap = 0 }</code></p> + + </section> + + <section> + <title>Examples</title> + </section> +</chapter> diff --git a/lib/runtime_tools/doc/src/Makefile b/lib/runtime_tools/doc/src/Makefile index 0a590ff9ec..5ce40bb995 100644 --- a/lib/runtime_tools/doc/src/Makefile +++ b/lib/runtime_tools/doc/src/Makefile @@ -45,7 +45,7 @@ XML_REF3_FILES = dbg.xml dyntrace.xml erts_alloc_config.xml system_information.x XML_REF6_FILES = runtime_tools_app.xml XML_PART_FILES = part_notes.xml part_notes_history.xml part.xml -XML_CHAPTER_FILES = notes.xml notes_history.xml +XML_CHAPTER_FILES = notes.xml notes_history.xml LTTng.xml GENERATED_XML_FILES = DTRACE.xml SYSTEMTAP.xml diff --git a/lib/runtime_tools/doc/src/part.xml b/lib/runtime_tools/doc/src/part.xml index 14e8b71c83..34acf69fc8 100644 --- a/lib/runtime_tools/doc/src/part.xml +++ b/lib/runtime_tools/doc/src/part.xml @@ -34,6 +34,7 @@ <p><em>Runtime Tools</em></p> </description> + <xi:include href="LTTng.xml"/> <xi:include href="DTRACE.xml"/> <xi:include href="SYSTEMTAP.xml"/> </part> diff --git a/lib/runtime_tools/src/dyntrace.erl b/lib/runtime_tools/src/dyntrace.erl index f7dbef6929..28e6d67d96 100644 --- a/lib/runtime_tools/src/dyntrace.erl +++ b/lib/runtime_tools/src/dyntrace.erl @@ -41,6 +41,28 @@ pn/1, pn/2, pn/3, pn/4, pn/5, pn/6, pn/7, pn/8, pn/9]). -export([put_tag/1, get_tag/0, get_tag_data/0, spread_tag/1, restore_tag/1]). +-export([trace/5, + trace/6, + trace_procs/6, + trace_ports/6, + trace_running_procs/6, + trace_running_ports/6, + trace_call/6, + trace_send/6, + trace_receive/6, + trace_garbage_collection/6]). + +-export([enabled_procs/3, + enabled_ports/3, + enabled_running_procs/3, + enabled_running_ports/3, + enabled_call/3, + enabled_send/3, + enabled_receive/3, + enabled_garbage_collection/3, + enabled/3]). + + -export([user_trace_i4s4/9]). % Know what you're doing! -on_load(on_load/0). @@ -125,6 +147,63 @@ user_trace_i4s4(_, _, _, _, _, _, _, _, _) -> user_trace_n(_, _, _, _, _, _, _, _, _, _) -> erlang:nif_error(nif_not_loaded). +trace(_TracerState, _Label, _SeqTraceInfo, _, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_procs(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_ports(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_running_procs(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_running_ports(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_call(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_send(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_receive(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_garbage_collection(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +enabled(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_procs(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_ports(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_running_procs(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_running_ports(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_call(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_send(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_receive(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_garbage_collection(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + %%% %%% Erlang support functions %%% diff --git a/lib/runtime_tools/test/Makefile b/lib/runtime_tools/test/Makefile index 432a361468..61377ea09e 100644 --- a/lib/runtime_tools/test/Makefile +++ b/lib/runtime_tools/test/Makefile @@ -4,6 +4,7 @@ include $(ERL_TOP)/make/$(TARGET)/otp.mk MODULES = \ dyntrace_SUITE \ + dyntrace_lttng_SUITE \ runtime_tools_SUITE \ system_information_SUITE \ dbg_SUITE \ diff --git a/lib/runtime_tools/test/dyntrace_lttng_SUITE.erl b/lib/runtime_tools/test/dyntrace_lttng_SUITE.erl new file mode 100644 index 0000000000..e6c147b003 --- /dev/null +++ b/lib/runtime_tools/test/dyntrace_lttng_SUITE.erl @@ -0,0 +1,377 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2012-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% +-module(dyntrace_lttng_SUITE). +-include_lib("common_test/include/ct.hrl"). + +-export([all/0, suite/0]). +-export([init_per_suite/1, end_per_suite/1]). +-export([init_per_testcase/2, end_per_testcase/2]). + +%% Test cases +-export([t_lttng_list/1, + t_procs/1, + t_ports/1, + t_running_process/1, + t_running_port/1, + t_call/1, + t_call_return_to/1, + t_call_silent/1, + t_send/1, + t_receive/1, + t_garbage_collection/1, + t_all/1]). + +suite() -> + [{ct_hooks,[ts_install_cth]}, + {timetrap, {seconds, 10}}]. + +all() -> + [t_lttng_list, + t_procs, + t_ports, + t_running_process, + t_running_port, + t_call, + t_call_return_to, + t_call_silent, + t_send, + t_receive, + t_garbage_collection, + t_all]. + + +init_per_suite(Config) -> + case erlang:system_info(dynamic_trace) of + lttng -> + ensure_lttng_stopped("--all"), + Config; + _ -> + {skip, "No LTTng configured on system."} + end. + +end_per_suite(_Config) -> + ensure_lttng_stopped("--all"), + ok. + +init_per_testcase(Case, Config) -> + %% ensure loaded + _ = dyntrace:module_info(), + Name = atom_to_list(Case), + ok = ensure_lttng_started(Name, Config), + [{session, Name}|Config]. + +end_per_testcase(Case, _Config) -> + Name = atom_to_list(Case), + ok = ensure_lttng_stopped(Name), + ok. + +%% tracepoints +%% +%% com_ericsson_dyntrace:gc_major_end +%% com_ericsson_dyntrace:gc_major_start +%% com_ericsson_dyntrace:gc_minor_end +%% com_ericsson_dyntrace:gc_minor_start +%% com_ericsson_dyntrace:message_receive +%% com_ericsson_dyntrace:message_send +%% -com_ericsson_dyntrace:message_queued +%% com_ericsson_dyntrace:function_exception +%% com_ericsson_dyntrace:function_return +%% com_ericsson_dyntrace:function_call +%% com_ericsson_dyntrace:port_link +%% com_ericsson_dyntrace:port_exit +%% com_ericsson_dyntrace:port_open +%% com_ericsson_dyntrace:port_scheduled +%% com_ericsson_dyntrace:process_scheduled +%% com_ericsson_dyntrace:process_register +%% com_ericsson_dyntrace:process_exit +%% com_ericsson_dyntrace:process_link +%% com_ericsson_dyntrace:process_spawn +%% +%% Testcases +%% + +t_lttng_list(_Config) -> + {ok, _} = cmd("lttng list -u"), + ok. + +t_procs(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:process_*", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},procs]), + + Pid = spawn_link(fun() -> waiter() end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + timer:sleep(1000), + + _ = erlang:trace(all, false, [procs]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:process_spawn", Res), + ok = check_tracepoint("com_ericsson_dyntrace:process_link", Res), + ok = check_tracepoint("com_ericsson_dyntrace:process_exit", Res), + ok = check_tracepoint("com_ericsson_dyntrace:process_register", Res), + ok. + +t_ports(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:port_*", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},ports]), + + _ = os:cmd("ls"), + + _ = erlang:trace(all, false, [{tracer, dyntrace, []},ports]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:port_open", Res), + ok = check_tracepoint("com_ericsson_dyntrace:port_link", Res), + ok = check_tracepoint("com_ericsson_dyntrace:port_exit", Res), + ok. + +t_running_process(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:process_scheduled", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},running]), + + Pid = spawn_link(fun() -> waiter() end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + timer:sleep(1000), + + _ = erlang:trace(all, false, [running]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:process_scheduled", Res), + ok. + +t_running_port(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:port_scheduled", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},running_ports]), + + _ = os:cmd("ls"), + _ = os:cmd("ls"), + + _ = erlang:trace(all, false, [running_ports]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:port_scheduled", Res), + ok. + + +t_call(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:function_*", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []}, call]), + _ = erlang:trace_pattern({?MODULE, '_', '_'}, [{'_',[],[{exception_trace}]}], [local]), + + DontLink = spawn(fun() -> foo_clause_exception(nope) end), + Pid = spawn_link(fun() -> waiter() end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + + timer:sleep(10), + undefined = erlang:process_info(DontLink), + + _ = erlang:trace_pattern({?MODULE, '_', '_'}, false, [local]), + _ = erlang:trace(all, false, [call]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:function_call", Res), + ok = check_tracepoint("com_ericsson_dyntrace:function_return", Res), + ok = check_tracepoint("com_ericsson_dyntrace:function_exception", Res), + ok. + +t_send(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:message_send", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},send]), + + Pid = spawn_link(fun() -> waiter() end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + _ = os:cmd("ls"), + timer:sleep(10), + + _ = erlang:trace(all, false, [send]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:message_send", Res), + ok. + +t_call_return_to(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:function_*", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []}, call, return_to]), + _ = erlang:trace_pattern({lists, '_', '_'}, true, [local]), + _ = erlang:trace_pattern({?MODULE, '_', '_'}, true, [local]), + + Pid = spawn_link(fun() -> gcfier(10) end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + timer:sleep(10), + + _ = erlang:trace_pattern({?MODULE, '_', '_'}, false, [local]), + _ = erlang:trace_pattern({lists, '_', '_'}, false, [local]), + _ = erlang:trace(all, false, [call,return_to]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:function_call", Res), + ok. + +t_call_silent(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:function_*", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []}, call, silent]), + _ = erlang:trace_pattern({?MODULE, '_', '_'}, [{'_',[],[{exception_trace}]}], [local]), + + DontLink = spawn(fun() -> foo_clause_exception(nope) end), + Pid = spawn_link(fun() -> waiter() end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + + timer:sleep(10), + undefined = erlang:process_info(DontLink), + + _ = erlang:trace_pattern({?MODULE, '_', '_'}, false, [local]), + _ = erlang:trace(all, false, [call]), + Res = lttng_stop_and_view(Config), + notfound = check_tracepoint("com_ericsson_dyntrace:function_call", Res), + notfound = check_tracepoint("com_ericsson_dyntrace:function_return", Res), + notfound = check_tracepoint("com_ericsson_dyntrace:function_exception", Res), + ok. + + +t_receive(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:message_receive", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},'receive']), + + Pid = spawn_link(fun() -> waiter() end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + timer:sleep(10), + _ = erlang:trace(all, false, ['receive']), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:message_receive", Res), + ok. + +t_garbage_collection(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:gc_*", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},garbage_collection]), + + Pid = spawn_link(fun() -> gcfier() end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + timer:sleep(10), + _ = erlang:trace(all, false, [garbage_collection]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:gc_major_start", Res), + ok = check_tracepoint("com_ericsson_dyntrace:gc_major_end", Res), + ok = check_tracepoint("com_ericsson_dyntrace:gc_minor_start", Res), + ok = check_tracepoint("com_ericsson_dyntrace:gc_minor_end", Res), + ok. + +t_all(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:*", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},all]), + + Pid1 = spawn_link(fun() -> waiter() end), + Pid1 ! {self(), ok}, + ok = receive {Pid1,ok} -> ok end, + + Pid2 = spawn_link(fun() -> gcfier() end), + Pid2 ! {self(), ok}, + ok = receive {Pid2,ok} -> ok end, + _ = os:cmd("ls"), + _ = os:cmd("ls"), + timer:sleep(10), + + _ = erlang:trace(all, false, [all]), + Res = lttng_stop_and_view(Config), + + ok = check_tracepoint("com_ericsson_dyntrace:process_spawn", Res), + ok = check_tracepoint("com_ericsson_dyntrace:process_link", Res), + ok = check_tracepoint("com_ericsson_dyntrace:process_exit", Res), + ok = check_tracepoint("com_ericsson_dyntrace:process_register", Res), + ok = check_tracepoint("com_ericsson_dyntrace:port_open", Res), + ok = check_tracepoint("com_ericsson_dyntrace:port_link", Res), + ok = check_tracepoint("com_ericsson_dyntrace:port_exit", Res), + ok = check_tracepoint("com_ericsson_dyntrace:process_scheduled", Res), + ok = check_tracepoint("com_ericsson_dyntrace:port_scheduled", Res), + ok = check_tracepoint("com_ericsson_dyntrace:message_send", Res), + ok = check_tracepoint("com_ericsson_dyntrace:message_receive", Res), + ok = check_tracepoint("com_ericsson_dyntrace:gc_major_start", Res), + ok = check_tracepoint("com_ericsson_dyntrace:gc_major_end", Res), + ok = check_tracepoint("com_ericsson_dyntrace:gc_minor_start", Res), + ok = check_tracepoint("com_ericsson_dyntrace:gc_minor_end", Res), + ok. + + +%% aux + +gcfier() -> + gcfier(10000). +gcfier(N) -> + receive + {Pid, ok} -> + _ = lists:reverse(lists:seq(1,N)), + true = erlang:garbage_collect(), + Pid ! {self(), ok} + end. + + +waiter() -> + true = register(?MODULE, self()), + receive + {Pid, ok} -> + Child = spawn(fun() -> receive ok -> ok end end), + link(Child), + unlink(Child), + _ = lists:seq(1,1000), + Child ! ok, + true = unregister(?MODULE), + Pid ! {self(),ok} + end. + +foo_clause_exception({1,2}) -> badness. + +%% lttng +lttng_stop_and_view(Config) -> + Path = proplists:get_value(priv_dir, Config), + Name = proplists:get_value(session, Config), + {ok,_} = cmd("lttng stop " ++ Name), + {ok,Res} = cmd("lttng view " ++ Name ++ " --trace-path=" ++ Path), + Res. + +check_tracepoint(TP, Data) -> + case re:run(Data, TP, [global]) of + {match, _} -> ok; + _ -> notfound + end. + +lttng_start_event(Event, Config) -> + Name = proplists:get_value(session, Config), + {ok, _} = cmd("lttng enable-event -u " ++ Event ++ " --session=" ++ Name), + {ok, _} = cmd("lttng start " ++ Name), + ok. + +ensure_lttng_started(Name, Config) -> + Out = case proplists:get_value(priv_dir, Config) of + undefined -> []; + Path -> "--output="++Path++" " + end, + {ok,_} = cmd("lttng create " ++ Out ++ Name), + ok. + +ensure_lttng_stopped(Name) -> + {ok,_} = cmd("lttng stop"), + {ok,_} = cmd("lttng destroy " ++ Name), + ok. + +cmd(Cmd) -> + io:format("<< ~ts~n", [Cmd]), + Res = os:cmd(Cmd), + io:format(">> ~ts~n", [Res]), + {ok,Res}. diff --git a/lib/ssh/doc/src/ssh.xml b/lib/ssh/doc/src/ssh.xml index 33aacb8ffe..ff2d6e082a 100644 --- a/lib/ssh/doc/src/ssh.xml +++ b/lib/ssh/doc/src/ssh.xml @@ -360,7 +360,8 @@ </type> <desc> <p>Starts a server listening for SSH connections on the given - port.</p> + port. If the <c>Port</c> is 0, a random free port is selected. See + <seealso marker="#daemon_info/1">daemon_info/1</seealso> about how to find the selected port number.</p> <p>Options:</p> <taglist> <tag><c><![CDATA[{inet, inet | inet6}]]></c></tag> @@ -682,6 +683,18 @@ </func> <func> + <name>daemon_info(Daemon) -> {ok, [{port,Port}]} | {error,Error}</name> + <fsummary>Get info about a daemon</fsummary> + <type> + <v>Port = integer()</v> + <v>Error = bad_daemon_ref</v> + </type> + <desc> + <p>Returns a key-value list with information about the daemon. For now, only the listening port is returned. This is intended for the case the daemon is started with the port set to 0.</p> + </desc> + </func> + + <func> <name>default_algorithms() -> algs_list()</name> <fsummary>Get a list declaring the supported algorithms</fsummary> <desc> diff --git a/lib/ssh/doc/src/ssh_sftp.xml b/lib/ssh/doc/src/ssh_sftp.xml index 1d37933369..071d46ec57 100644 --- a/lib/ssh/doc/src/ssh_sftp.xml +++ b/lib/ssh/doc/src/ssh_sftp.xml @@ -44,24 +44,41 @@ </p> <taglist> + <tag><c>reason()</c></tag> + <item> + <p>= <c>atom()</c> A description of the reason why an operation failed.</p> + <p> + The value is formed from the sftp error codes in the protocol-level responses as defined in + <url href="https://tools.ietf.org/id/draft-ietf-secsh-filexfer-13.txt">draft-ietf-secsh-filexfer-13.txt</url> + section 9.1. + </p> + <p> + The codes are named as <c>SSH_FX_*</c> which are transformed into lowercase of the star-part. + E.g. the error code <c>SSH_FX_NO_SUCH_FILE</c> + will cause the <c>reason()</c> to be <c>no_such_file</c>. + </p> + </item> + <tag><c>ssh_connection_ref() =</c></tag> - <item><p>opaque() - as returned by <c>ssh:connect/3</c></p></item> + <item><p><c>opaque()</c> - as returned by + <seealso marker="ssh#connect-3"><c>ssh:connect/3</c></seealso></p></item> + <tag><c>timeout()</c></tag> - <item><p>= <c>infinity | integer() in milliseconds. Default infinity.</c></p></item> + <item><p>= <c>infinity | integer()</c> in milliseconds. Default infinity.</p></item> </taglist> </section> <section> <title>Time-outs</title> <p>If the request functions for the SFTP channel return <c>{error, timeout}</c>, - it does not guarantee that the request never reached the server and was - not performed. It only means that no answer was received from the - server within the expected time.</p> + no answer was received from the server within the expected time.</p> + <p>The request may have reached the server and may have been performed. + However, no answer was received from the server within the expected time.</p> </section> <funcs> <func> - <name>apread(ChannelPid, Handle, Position, Len) -> {async, N} | {error, Reason}</name> + <name>apread(ChannelPid, Handle, Position, Len) -> {async, N} | {error, reason()}</name> <fsummary>Reads asynchronously from an open file.</fsummary> <type> <v>ChannelPid = pid()</v> @@ -69,16 +86,15 @@ <v>Position = integer()</v> <v>Len = integer()</v> <v>N = term()</v> - <v>Reason = term()</v> </type> - - <desc><p>The <c><![CDATA[apread]]></c> function reads from a specified position, - combining the <c><![CDATA[position]]></c> and <c><![CDATA[aread]]></c> functions.</p> - <p><seealso marker="#apread-4">ssh_sftp:apread/4</seealso></p> </desc> + <desc><p>The <c><![CDATA[apread/4]]></c> function reads from a specified position, + combining the <seealso marker="#position-3"><c>position/3</c></seealso> and + <seealso marker="#aread-3"><c>aread/3</c></seealso> functions.</p> + </desc> </func> <func> - <name>apwrite(ChannelPid, Handle, Position, Data) -> ok | {error, Reason}</name> + <name>apwrite(ChannelPid, Handle, Position, Data) -> {async, N} | {error, reason()}</name> <fsummary>Writes asynchronously to an open file.</fsummary> <type> <v>ChannelPid = pid()</v> @@ -87,16 +103,16 @@ <v>Len = integer()</v> <v>Data = binary()</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> + <v>N = term()</v> </type> - <desc> - <p><c><![CDATA[apwrite]]></c> writes on a specified position, combining - the <c><![CDATA[position]]></c> and <c><![CDATA[awrite]]></c> operations.</p> - <p><seealso marker="#awrite-3">ssh_sftp:awrite/3</seealso> </p></desc> + <desc><p>The <c><![CDATA[apwrite/4]]></c> function writes to a specified position, + combining the <seealso marker="#position-3"><c>position/3</c></seealso> and + <seealso marker="#awrite-3"><c>awrite/3</c></seealso> functions.</p> + </desc> </func> <func> - <name>aread(ChannelPid, Handle, Len) -> {async, N} | {error, Error}</name> + <name>aread(ChannelPid, Handle, Len) -> {async, N} | {error, reason()}</name> <fsummary>Reads asynchronously from an open file.</fsummary> <type> <v>ChannelPid = pid()</v> @@ -104,7 +120,6 @@ <v>Position = integer()</v> <v>Len = integer()</v> <v>N = term()</v> - <v>Reason = term()</v> </type> <desc> <p>Reads from an open file, without waiting for the result. If the @@ -113,14 +128,12 @@ The actual data is sent as a message to the calling process. This message has the form <c><![CDATA[{async_reply, N, Result}]]></c>, where <c><![CDATA[Result]]></c> is the result from the read, either <c><![CDATA[{ok, Data}]]></c>, - <c><![CDATA[eof]]></c>, or <c><![CDATA[{error, Error}]]></c>.</p> + <c><![CDATA[eof]]></c>, or <c><![CDATA[{error, reason()}]]></c>.</p> </desc> </func> - - <func> - <name>awrite(ChannelPid, Handle, Data) -> ok | {error, Reason}</name> + <name>awrite(ChannelPid, Handle, Data) -> {async, N} | {error, reason()}</name> <fsummary>Writes asynchronously to an open file.</fsummary> <type> <v>ChannelPid = pid()</v> @@ -129,7 +142,6 @@ <v>Len = integer()</v> <v>Data = binary()</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> </type> <desc> <p>Writes to an open file, without waiting for the result. If the @@ -138,19 +150,18 @@ <c><![CDATA[awrite]]></c>. The result of the <c><![CDATA[write]]></c> operation is sent as a message to the calling process. This message has the form <c><![CDATA[{async_reply, N, Result}]]></c>, where <c><![CDATA[Result]]></c> is the result - from the write, either <c><![CDATA[ok]]></c>, or <c><![CDATA[{error, Error}]]></c>.</p> + from the write, either <c><![CDATA[ok]]></c>, or <c><![CDATA[{error, reason()}]]></c>.</p> </desc> </func> <func> <name>close(ChannelPid, Handle) -></name> - <name>close(ChannelPid, Handle, Timeout) -> ok | {error, Reason}</name> + <name>close(ChannelPid, Handle, Timeout) -> ok | {error, reason()}</name> <fsummary>Closes an open handle.</fsummary> <type> <v>ChannelPid = pid()</v> <v>Handle = term()</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> </type> <desc> <p>Closes a handle to an open file or directory on the server.</p> @@ -159,29 +170,27 @@ <func> <name>delete(ChannelPid, Name) -></name> - <name>delete(ChannelPid, Name, Timeout) -> ok | {error, Reason}</name> + <name>delete(ChannelPid, Name, Timeout) -> ok | {error, reason()}</name> <fsummary>Deletes a file.</fsummary> <type> <v>ChannelPid = pid()</v> <v>Name = string()</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> </type> <desc> - <p>Deletes the file specified by <c><![CDATA[Name]]></c>, like - <seealso marker="kernel:file#delete-1">file:delete/1</seealso></p> + <p>Deletes the file specified by <c><![CDATA[Name]]></c>. + </p> </desc> </func> <func> <name>del_dir(ChannelPid, Name) -></name> - <name>del_dir(ChannelPid, Name, Timeout) -> ok | {error, Reason}</name> + <name>del_dir(ChannelPid, Name, Timeout) -> ok | {error, reason()}</name> <fsummary>Deletes an empty directory.</fsummary> <type> <v>ChannelPid = pid()</v> <v>Name = string()</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> </type> <desc> <p>Deletes a directory specified by <c><![CDATA[Name]]></c>. @@ -192,7 +201,7 @@ <func> <name>list_dir(ChannelPid, Path) -></name> - <name>list_dir(ChannelPid, Path, Timeout) -> {ok, Filenames} | {error, Reason}</name> + <name>list_dir(ChannelPid, Path, Timeout) -> {ok, Filenames} | {error, reason()}</name> <fsummary>Lists the directory.</fsummary> <type> <v>ChannelPid = pid()</v> @@ -200,7 +209,6 @@ <v>Filenames = [Filename]</v> <v>Filename = string()</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> </type> <desc> <p>Lists the given directory on the server, returning the @@ -210,13 +218,12 @@ <func> <name>make_dir(ChannelPid, Name) -></name> - <name>make_dir(ChannelPid, Name, Timeout) -> ok | {error, Reason}</name> + <name>make_dir(ChannelPid, Name, Timeout) -> ok | {error, reason()}</name> <fsummary>Creates a directory.</fsummary> <type> <v>ChannelPid = pid()</v> <v>Name = string()</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> </type> <desc> <p>Creates a directory specified by <c><![CDATA[Name]]></c>. <c><![CDATA[Name]]></c> @@ -227,24 +234,23 @@ <func> <name>make_symlink(ChannelPid, Name, Target) -></name> - <name>make_symlink(ChannelPid, Name, Target, Timeout) -> ok | {error, Reason}</name> + <name>make_symlink(ChannelPid, Name, Target, Timeout) -> ok | {error, reason()}</name> <fsummary>Creates a symbolic link.</fsummary> <type> <v>ChannelPid = pid()</v> <v>Name = string()</v> <v>Target = string()</v> - <v>Reason = term()</v> </type> <desc> <p>Creates a symbolic link pointing to <c><![CDATA[Target]]></c> with the - name <c><![CDATA[Name]]></c>, like - <seealso marker="kernel:file#make_symlink-2">file:make_symlink/2</seealso></p> + name <c><![CDATA[Name]]></c>. + </p> </desc> </func> <func> <name>open(ChannelPid, File, Mode) -></name> - <name>open(ChannelPid, File, Mode, Timeout) -> {ok, Handle} | {error, Reason}</name> + <name>open(ChannelPid, File, Mode, Timeout) -> {ok, Handle} | {error, reason()}</name> <fsummary>Opens a file and returns a handle.</fsummary> <type> <v>ChannelPid = pid()</v> @@ -253,7 +259,6 @@ <v>Modeflag = read | write | creat | trunc | append | binary</v> <v>Timeout = timeout()</v> <v>Handle = term()</v> - <v>Reason = term()</v> </type> <desc> <p>Opens a file on the server and returns a handle, which @@ -262,13 +267,12 @@ </func> <func> <name>opendir(ChannelPid, Path) -></name> - <name>opendir(ChannelPid, Path, Timeout) -> {ok, Handle} | {error, Reason}</name> + <name>opendir(ChannelPid, Path, Timeout) -> {ok, Handle} | {error, reason()}</name> <fsummary>Opens a directory and returns a handle.</fsummary> <type> <v>ChannelPid = pid()</v> <v>Path = string()</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> </type> <desc> <p>Opens a handle to a directory on the server. The handle @@ -278,7 +282,7 @@ <func> <name>open_tar(ChannelPid, Path, Mode) -></name> - <name>open_tar(ChannelPid, Path, Mode, Timeout) -> {ok, Handle} | {error, Reason}</name> + <name>open_tar(ChannelPid, Path, Mode, Timeout) -> {ok, Handle} | {error, reason()}</name> <fsummary>Opens a tar file on the server to which <c>ChannelPid</c> is connected and returns a handle.</fsummary> <type> @@ -298,7 +302,6 @@ <v>DecryptResult = {ok,PlainBin,CryptoState} | {ok,PlainBin,CryptoState,ChunkSize}</v> <v>CloseFun = (fun(PlainBin,CryptoState) -> {ok,EncryptedBin})</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> </type> <desc> <p>Opens a handle to a tar file on the server, associated with <c>ChannelPid</c>. @@ -333,7 +336,7 @@ <func> <name>position(ChannelPid, Handle, Location) -></name> - <name>position(ChannelPid, Handle, Location, Timeout) -> {ok, NewPosition} | {error, Reason}</name> + <name>position(ChannelPid, Handle, Location, Timeout) -> {ok, NewPosition | {error, reason()}</name> <fsummary>Sets the file position of a file.</fsummary> <type> <v>ChannelPid = pid()</v> @@ -343,12 +346,11 @@ <v>Offset = integer()</v> <v>Timeout = timeout()</v> <v>NewPosition = integer()</v> - <v>Reason = term()</v> </type> <desc> <p>Sets the file position of the file referenced by <c><![CDATA[Handle]]></c>. Returns <c><![CDATA[{ok, NewPosition}]]></c> (as an absolute offset) if - successful, otherwise <c><![CDATA[{error, Reason}]]></c>. <c><![CDATA[Location]]></c> is + successful, otherwise <c><![CDATA[{error, reason()}]]></c>. <c><![CDATA[Location]]></c> is one of the following:</p> <taglist> <tag><c><![CDATA[Offset]]></c></tag> @@ -379,7 +381,7 @@ <func> <name>pread(ChannelPid, Handle, Position, Len) -></name> - <name>pread(ChannelPid, Handle, Position, Len, Timeout) -> {ok, Data} | eof | {error, Error}</name> + <name>pread(ChannelPid, Handle, Position, Len, Timeout) -> {ok, Data} | eof | {error, reason()}</name> <fsummary>Reads from an open file.</fsummary> <type> <v>ChannelPid = pid()</v> @@ -388,18 +390,16 @@ <v>Len = integer()</v> <v>Timeout = timeout()</v> <v>Data = string() | binary()</v> - <v>Reason = term()</v> </type> - <desc> - <p>The <c><![CDATA[pread]]></c> function reads from a specified position, - combining the <c><![CDATA[position]]></c> and <c><![CDATA[read]]></c> functions.</p> - <p><seealso marker="#read-4">ssh_sftp:read/4</seealso></p> - </desc> - </func> + <desc><p>The <c><![CDATA[pread/3,4]]></c> function reads from a specified position, + combining the <seealso marker="#position-3"><c>position/3</c></seealso> and + <seealso marker="#read-3"><c>read/3,4</c></seealso> functions.</p> + </desc> + </func> <func> <name>pwrite(ChannelPid, Handle, Position, Data) -> ok</name> - <name>pwrite(ChannelPid, Handle, Position, Data, Timeout) -> ok | {error, Reason}</name> + <name>pwrite(ChannelPid, Handle, Position, Data, Timeout) -> ok | {error, reason()}</name> <fsummary>Writes to an open file.</fsummary> <type> <v>ChannelPid = pid()</v> @@ -407,19 +407,16 @@ <v>Position = integer()</v> <v>Data = iolist()</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> </type> - <desc> - <p>The <c><![CDATA[pread]]></c> function writes to a specified position, - combining the <c><![CDATA[position]]></c> and <c><![CDATA[write]]></c> functions.</p> - <p><seealso marker="#write-3">ssh_sftp:write/3</seealso></p> - </desc> + <desc><p>The <c><![CDATA[pwrite/3,4]]></c> function writes to a specified position, + combining the <seealso marker="#position-3"><c>position/3</c></seealso> and + <seealso marker="#write-3"><c>write/3,4</c></seealso> functions.</p> + </desc> </func> - - <func> + <func> <name>read(ChannelPid, Handle, Len) -></name> - <name>read(ChannelPid, Handle, Len, Timeout) -> {ok, Data} | eof | {error, Error}</name> + <name>read(ChannelPid, Handle, Len, Timeout) -> {ok, Data} | eof | {error, reason()}</name> <fsummary>Reads from an open file.</fsummary> <type> <v>ChannelPid = pid()</v> @@ -428,12 +425,11 @@ <v>Len = integer()</v> <v>Timeout = timeout()</v> <v>Data = string() | binary()</v> - <v>Reason = term()</v> </type> <desc> <p>Reads <c><![CDATA[Len]]></c> bytes from the file referenced by <c><![CDATA[Handle]]></c>. Returns <c><![CDATA[{ok, Data}]]></c>, <c><![CDATA[eof]]></c>, or - <c><![CDATA[{error, Reason}]]></c>. If the file is opened with <c><![CDATA[binary]]></c>, + <c><![CDATA[{error, reason()}]]></c>. If the file is opened with <c><![CDATA[binary]]></c>, <c><![CDATA[Data]]></c> is a binary, otherwise it is a string.</p> <p>If the file is read past <c>eof</c>, only the remaining bytes are read and returned. If no bytes are read, <c><![CDATA[eof]]></c> @@ -443,25 +439,22 @@ <func> <name>read_file(ChannelPid, File) -></name> - <name>read_file(ChannelPid, File, Timeout) -> {ok, Data} | {error, Reason}</name> + <name>read_file(ChannelPid, File, Timeout) -> {ok, Data} | {error, reason()}</name> <fsummary>Reads a file.</fsummary> <type> <v>ChannelPid = pid()</v> <v>File = string()</v> <v>Data = binary()</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> </type> <desc> - <p>Reads a file from the server, and returns the data in a binary, - like - <seealso marker="kernel:file#read_file-1">file:read_file/1</seealso></p> + <p>Reads a file from the server, and returns the data in a binary.</p> </desc> </func> <func> <name>read_file_info(ChannelPid, Name) -></name> - <name>read_file_info(ChannelPid, Name, Timeout) -> {ok, FileInfo} | {error, Reason}</name> + <name>read_file_info(ChannelPid, Name, Timeout) -> {ok, FileInfo} | {error, reason()}</name> <fsummary>Gets information about a file.</fsummary> <type> <v>ChannelPid = pid()</v> @@ -469,35 +462,34 @@ <v>Handle = term()</v> <v>Timeout = timeout()</v> <v>FileInfo = record()</v> - <v>Reason = term()</v> </type> <desc> <p>Returns a <c><![CDATA[file_info]]></c> record from the file specified by - <c><![CDATA[Name]]></c> or <c><![CDATA[Handle]]></c>, - like <seealso marker="kernel:file#read_file_info-2">file:read_file_info/2</seealso></p> + <c><![CDATA[Name]]></c> or <c><![CDATA[Handle]]></c>. See + <seealso marker="kernel:file#read_file_info-2">file:read_file_info/2</seealso> + for information about the record. + </p> </desc> </func> <func> <name>read_link(ChannelPid, Name) -></name> - <name>read_link(ChannelPid, Name, Timeout) -> {ok, Target} | {error, Reason}</name> + <name>read_link(ChannelPid, Name, Timeout) -> {ok, Target} | {error, reason()}</name> <fsummary>Reads symbolic link.</fsummary> <type> <v>ChannelPid = pid()</v> <v>Name = string()</v> <v>Target = string()</v> - <v>Reason = term()</v> </type> <desc> - <p>Reads the link target from the symbolic link specified - by <c><![CDATA[name]]></c>, like - <seealso marker="kernel:file#read_link-1">file:read_link/1</seealso></p> + <p>Reads the link target from the symbolic link specified by <c><![CDATA[name]]></c>. + </p> </desc> </func> <func> - <name>read_link_info(ChannelPid, Name) -> {ok, FileInfo} | {error, Reason}</name> - <name>read_link_info(ChannelPid, Name, Timeout) -> {ok, FileInfo} | {error, Reason}</name> + <name>read_link_info(ChannelPid, Name) -> {ok, FileInfo} | {error, reason()}</name> + <name>read_link_info(ChannelPid, Name, Timeout) -> {ok, FileInfo} | {error, reason()}</name> <fsummary>Gets information about a symbolic link.</fsummary> <type> <v>ChannelPid = pid()</v> @@ -505,30 +497,31 @@ <v>Handle = term()</v> <v>Timeout = timeout()</v> <v>FileInfo = record()</v> - <v>Reason = term()</v> </type> <desc> <p>Returns a <c><![CDATA[file_info]]></c> record from the symbolic - link specified by <c><![CDATA[Name]]></c> or <c><![CDATA[Handle]]></c>, like - <seealso marker="kernel:file#read_link_info-2">file:read_link_info/2</seealso></p> + link specified by <c><![CDATA[Name]]></c> or <c><![CDATA[Handle]]></c>. + See + <seealso marker="kernel:file#read_link_info-2">file:read_link_info/2</seealso> + for information about the record. + </p> </desc> </func> <func> <name>rename(ChannelPid, OldName, NewName) -> </name> - <name>rename(ChannelPid, OldName, NewName, Timeout) -> ok | {error, Reason}</name> + <name>rename(ChannelPid, OldName, NewName, Timeout) -> ok | {error, reason()}</name> <fsummary>Renames a file.</fsummary> <type> <v>ChannelPid = pid()</v> <v>OldName = string()</v> <v>NewName = string()</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> </type> <desc> <p>Renames a file named <c><![CDATA[OldName]]></c> and gives it the name - <c><![CDATA[NewName]]></c>, like - <seealso marker="kernel:file#rename-2">file:rename/2</seealso></p> + <c><![CDATA[NewName]]></c>. + </p> </desc> </func> @@ -537,14 +530,13 @@ <name>start_channel(ConnectionRef, Options) -></name> <name>start_channel(Host, Options) -></name> <name>start_channel(Host, Port, Options) -> {ok, Pid} | {ok, Pid, ConnectionRef} | - {error, Reason}</name> + {error, reason()|term()}</name> <fsummary>Starts an SFTP client.</fsummary> <type> <v>Host = string()</v> <v>ConnectionRef = ssh_connection_ref()</v> <v>Port = integer()</v> <v>Options = [{Option, Value}]</v> - <v>Reason = term()</v> </type> <desc> <p>If no connection reference is provided, a connection is set @@ -592,7 +584,7 @@ <func> <name>write(ChannelPid, Handle, Data) -></name> - <name>write(ChannelPid, Handle, Data, Timeout) -> ok | {error, Reason}</name> + <name>write(ChannelPid, Handle, Data, Timeout) -> ok | {error, reason()}</name> <fsummary>Writes to an open file.</fsummary> <type> <v>ChannelPid = pid()</v> @@ -600,61 +592,47 @@ <v>Position = integer()</v> <v>Data = iolist()</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> </type> <desc> <p>Writes <c><![CDATA[data]]></c> to the file referenced by <c><![CDATA[Handle]]></c>. The file is to be opened with <c><![CDATA[write]]></c> or <c><![CDATA[append]]></c> - flag. Returns <c><![CDATA[ok]]></c> if successful or <c><![CDATA[{error, Reason}]]></c> + flag. Returns <c><![CDATA[ok]]></c> if successful or <c><![CDATA[{error, reason()}]]></c> otherwise.</p> - <p>Typical error reasons:</p> - <taglist> - <tag><c><![CDATA[ebadf]]></c></tag> - <item> - <p>File is not opened for writing.</p> - </item> - <tag><c><![CDATA[enospc]]></c></tag> - <item> - <p>No space is left on the device.</p> - </item> - </taglist> </desc> </func> <func> <name>write_file(ChannelPid, File, Iolist) -></name> - <name>write_file(ChannelPid, File, Iolist, Timeout) -> ok | {error, Reason}</name> + <name>write_file(ChannelPid, File, Iolist, Timeout) -> ok | {error, reason()}</name> <fsummary>Writes a file.</fsummary> <type> <v>ChannelPid = pid()</v> <v>File = string()</v> <v>Iolist = iolist()</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> </type> <desc> - <p>Writes a file to the server, like <seealso - marker="kernel:file#write_file-2">file:write_file/2</seealso> The - file is created if it does not exist. The file is overwritten - if it exists.</p> + <p>Writes a file to the server. The file is created if it does not exist + but overwritten if it exists.</p> </desc> </func> <func> <name>write_file_info(ChannelPid, Name, Info) -></name> - <name>write_file_info(ChannelPid, Name, Info, Timeout) -> ok | {error, Reason}</name> + <name>write_file_info(ChannelPid, Name, Info, Timeout) -> ok | {error, reason()}</name> <fsummary>Writes information for a file.</fsummary> <type> <v>ChannelPid = pid()</v> <v>Name = string()</v> <v>Info = record()</v> <v>Timeout = timeout()</v> - <v>Reason = term()</v> </type> <desc> <p>Writes file information from a <c><![CDATA[file_info]]></c> record to the - file specified by <c><![CDATA[Name]]></c>, like - <seealso marker="kernel:file#write_file_info-2">file:write_file_info/[2,3]</seealso></p> + file specified by <c><![CDATA[Name]]></c>. See + <seealso marker="kernel:file#write_file_info-2">file:write_file_info/[2,3]</seealso> + for information about the record. + </p> </desc> </func> </funcs> diff --git a/lib/ssh/src/ssh.app.src b/lib/ssh/src/ssh.app.src index c67350bf72..3245ba5197 100644 --- a/lib/ssh/src/ssh.app.src +++ b/lib/ssh/src/ssh.app.src @@ -40,7 +40,12 @@ {applications, [kernel, stdlib, crypto, public_key]}, {env, []}, {mod, {ssh_app, []}}, - {runtime_dependencies, ["stdlib-2.3","public_key-0.22","kernel-3.0", - "erts-6.0","crypto-3.3"]}]}. + {runtime_dependencies, [ + "crypto-3.3", + "erts-6.0", + "kernel-3.0", + "public_key-1.1", + "stdlib-3.0" + ]}]}. diff --git a/lib/ssh/src/ssh.erl b/lib/ssh/src/ssh.erl index d0121e73ba..09b07b7a2a 100644 --- a/lib/ssh/src/ssh.erl +++ b/lib/ssh/src/ssh.erl @@ -30,12 +30,18 @@ -export([start/0, start/1, stop/0, connect/3, connect/4, close/1, connection_info/2, channel_info/3, daemon/1, daemon/2, daemon/3, + daemon_info/1, default_algorithms/0, stop_listener/1, stop_listener/2, stop_listener/3, stop_daemon/1, stop_daemon/2, stop_daemon/3, shell/1, shell/2, shell/3 ]). +%%% Type exports +-export_type([connection_ref/0, + channel_id/0 + ]). + %%-------------------------------------------------------------------- -spec start() -> ok | {error, term()}. -spec start(permanent | transient | temporary) -> ok | {error, term()}. @@ -81,7 +87,7 @@ connect(Host, Port, Options, Timeout) -> ConnectionTimeout = proplists:get_value(connect_timeout, Options, infinity), try Transport:connect(Host, Port, [ {active, false} | SocketOptions], ConnectionTimeout) of {ok, Socket} -> - Opts = [{user_pid, self()}, {host, Host} | fix_idle_time(SshOptions)], + Opts = [{user_pid,self()}, {host,Host} | SshOptions], ssh_connection_handler:start_connection(client, Socket, Opts, Timeout); {error, Reason} -> {error, Reason} @@ -153,6 +159,19 @@ daemon(HostAddr, Port, Options0) -> start_daemon(Host, Port, Options, Inet). %%-------------------------------------------------------------------- +daemon_info(Pid) -> + case catch ssh_system_sup:acceptor_supervisor(Pid) of + AsupPid when is_pid(AsupPid) -> + [Port] = + [Prt || {{ssh_acceptor_sup,any,Prt,default}, + _WorkerPid,worker,[ssh_acceptor]} <- supervisor:which_children(AsupPid)], + {ok, [{port,Port}]}; + + _ -> + {error,bad_daemon_ref} + end. + +%%-------------------------------------------------------------------- -spec stop_listener(pid()) -> ok. -spec stop_listener(inet:ip_address(), integer()) -> ok. %% @@ -223,13 +242,6 @@ default_algorithms() -> %%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- -fix_idle_time(SshOptions) -> - case proplists:get_value(idle_time, SshOptions) of - undefined -> - [{idle_time, infinity}|SshOptions]; - _ -> - SshOptions - end. start_daemon(Host, Port, Options, Inet) -> case handle_options(Options) of {error, _Reason} = Error -> @@ -243,32 +255,52 @@ start_daemon(Host, Port, Options, Inet) -> end end. -do_start_daemon(Host0, Port0, Options, SocketOptions) -> - {Host,Port} = try - case proplists:get_value(fd, SocketOptions) of - undefined -> - {Host0,Port0}; - Fd when Port0==0 -> - find_hostport(Fd); - _ -> - {Host0,Port0} - end - catch - _:_ -> throw(bad_fd) - end, - Profile = proplists:get_value(profile, Options, ?DEFAULT_PROFILE), +do_start_daemon(Host0, Port0, SshOptions, SocketOptions) -> + {Host,Port1} = + try + case proplists:get_value(fd, SocketOptions) of + undefined -> + {Host0,Port0}; + Fd when Port0==0 -> + find_hostport(Fd); + _ -> + {Host0,Port0} + end + catch + _:_ -> throw(bad_fd) + end, + Profile = proplists:get_value(profile, SshOptions, ?DEFAULT_PROFILE), + {Port, WaitRequestControl, Opts} = + case Port1 of + 0 -> %% Allocate the socket here to get the port number... + {_, Callback, _} = + proplists:get_value(transport, SshOptions, {tcp, gen_tcp, tcp_closed}), + {ok,LSock} = ssh_acceptor:callback_listen(Callback, 0, SocketOptions), + {ok,{_,LPort}} = inet:sockname(LSock), + {LPort, + {LSock,Callback}, + [{lsocket,LSock},{lsock_owner,self()}] + }; + _ -> + {Port1, false, []} + end, case ssh_system_sup:system_supervisor(Host, Port, Profile) of undefined -> %% It would proably make more sense to call the %% address option host but that is a too big change at the %% monent. The name is a legacy name! try sshd_sup:start_child([{address, Host}, - {port, Port}, {role, server}, + {port, Port}, + {role, server}, {socket_opts, SocketOptions}, - {ssh_opts, Options}]) of + {ssh_opts, SshOptions} + | Opts]) of {error, {already_started, _}} -> {error, eaddrinuse}; - Result = {Code, _} when (Code == ok) or (Code == error) -> + Result = {ok,_} -> + sync_request_control(WaitRequestControl), + Result; + Result = {error, _} -> Result catch exit:{noproc, _} -> @@ -277,18 +309,31 @@ do_start_daemon(Host0, Port0, Options, SocketOptions) -> Sup -> AccPid = ssh_system_sup:acceptor_supervisor(Sup), case ssh_acceptor_sup:start_child(AccPid, [{address, Host}, - {port, Port}, {role, server}, + {port, Port}, + {role, server}, {socket_opts, SocketOptions}, - {ssh_opts, Options}]) of + {ssh_opts, SshOptions} + | Opts]) of {error, {already_started, _}} -> {error, eaddrinuse}; {ok, _} -> + sync_request_control(WaitRequestControl), {ok, Sup}; Other -> Other end end. +sync_request_control(false) -> + ok; +sync_request_control({LSock,Callback}) -> + receive + {request_control,LSock,ReqPid} -> + ok = Callback:controlling_process(LSock, ReqPid), + ReqPid ! {its_yours,LSock}, + ok + end. + find_hostport(Fd) -> %% Using internal functions inet:open/8 and inet:close/0. %% Don't try this at home unless you know what you are doing! diff --git a/lib/ssh/src/ssh.hrl b/lib/ssh/src/ssh.hrl index 73d6e4d2bc..868f3a9181 100644 --- a/lib/ssh/src/ssh.hrl +++ b/lib/ssh/src/ssh.hrl @@ -70,8 +70,6 @@ -record(ssh, { - %%state, %% what it's waiting for - role, %% client | server peer, %% string version of peer address @@ -135,8 +133,8 @@ user, service, userauth_quiet_mode, % boolean() - userauth_supported_methods, % string() eg "keyboard-interactive,password" userauth_methods, % list( string() ) eg ["keyboard-interactive", "password"] + userauth_supported_methods, % string() eg "keyboard-interactive,password" kb_tries_left = 0, % integer(), num tries left for "keyboard-interactive" userauth_preference, available_host_keys, diff --git a/lib/ssh/src/ssh_acceptor.erl b/lib/ssh/src/ssh_acceptor.erl index d94dedf1bf..90fd951dcd 100644 --- a/lib/ssh/src/ssh_acceptor.erl +++ b/lib/ssh/src/ssh_acceptor.erl @@ -26,7 +26,8 @@ %% Internal application API -export([start_link/5, - number_of_connections/1]). + number_of_connections/1, + callback_listen/3]). %% spawn export -export([acceptor_init/6, acceptor_loop/6]). @@ -46,15 +47,39 @@ start_link(Port, Address, SockOpts, Opts, AcceptTimeout) -> acceptor_init(Parent, Port, Address, SockOpts, Opts, AcceptTimeout) -> {_, Callback, _} = proplists:get_value(transport, Opts, {tcp, gen_tcp, tcp_closed}), - case (catch do_socket_listen(Callback, Port, [{active, false} | SockOpts])) of - {ok, ListenSocket} -> + + SockOwner = proplists:get_value(lsock_owner, Opts), + LSock = proplists:get_value(lsocket, Opts), + UseExistingSocket = + case catch inet:sockname(LSock) of + {ok,{_,Port}} -> is_pid(SockOwner); + _ -> false + end, + + case UseExistingSocket of + true -> proc_lib:init_ack(Parent, {ok, self()}), - acceptor_loop(Callback, - Port, Address, Opts, ListenSocket, AcceptTimeout); - Error -> - proc_lib:init_ack(Parent, Error), - error + request_ownership(LSock, SockOwner), + acceptor_loop(Callback, Port, Address, Opts, LSock, AcceptTimeout); + + false -> + case (catch do_socket_listen(Callback, Port, SockOpts)) of + {ok, ListenSocket} -> + proc_lib:init_ack(Parent, {ok, self()}), + acceptor_loop(Callback, + Port, Address, Opts, ListenSocket, AcceptTimeout); + Error -> + proc_lib:init_ack(Parent, Error), + error + end end. + +request_ownership(LSock, SockOwner) -> + SockOwner ! {request_control,LSock,self()}, + receive + {its_yours,LSock} -> ok + end. + do_socket_listen(Callback, Port0, Opts) -> Port = @@ -62,6 +87,10 @@ do_socket_listen(Callback, Port0, Opts) -> undefined -> Port0; _ -> 0 end, + callback_listen(Callback, Port, Opts). + +callback_listen(Callback, Port, Opts0) -> + Opts = [{active, false}, {reuseaddr,true} | Opts0], case Callback:listen(Port, Opts) of {error, nxdomain} -> Callback:listen(Port, lists:delete(inet6, Opts)); diff --git a/lib/ssh/src/ssh_acceptor_sup.erl b/lib/ssh/src/ssh_acceptor_sup.erl index b2f489a971..4f76dbe6f0 100644 --- a/lib/ssh/src/ssh_acceptor_sup.erl +++ b/lib/ssh/src/ssh_acceptor_sup.erl @@ -85,10 +85,7 @@ child_spec(ServerOpts) -> Profile = proplists:get_value(profile, proplists:get_value(ssh_opts, ServerOpts), ?DEFAULT_PROFILE), Name = id(Address, Port, Profile), SocketOpts = proplists:get_value(socket_opts, ServerOpts), - StartFunc = {ssh_acceptor, start_link, [Port, Address, - [{active, false}, - {reuseaddr, true}] ++ SocketOpts, - ServerOpts, Timeout]}, + StartFunc = {ssh_acceptor, start_link, [Port, Address, SocketOpts, ServerOpts, Timeout]}, Restart = transient, Shutdown = brutal_kill, Modules = [ssh_acceptor], diff --git a/lib/ssh/src/ssh_auth.erl b/lib/ssh/src/ssh_auth.erl index 4b3c21ce3f..49eec8072f 100644 --- a/lib/ssh/src/ssh_auth.erl +++ b/lib/ssh/src/ssh_auth.erl @@ -135,9 +135,9 @@ init_userauth_request_msg(#ssh{opts = Opts} = Ssh) -> service = "ssh-connection"}); {error, no_user} -> ErrStr = "Could not determine the users name", - throw(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_ILLEGAL_USER_NAME, - description = ErrStr, - language = "en"}) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{code = ?SSH_DISCONNECT_ILLEGAL_USER_NAME, + description = ErrStr}) end. userauth_request_msg(#ssh{userauth_preference = []} = Ssh) -> @@ -355,10 +355,10 @@ handle_userauth_info_response(#ssh_msg_userauth_info_response{num_responses = 1, handle_userauth_info_response(#ssh_msg_userauth_info_response{}, _Auth) -> - throw(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = "Server does not support" - "keyboard-interactive", - language = "en"}). + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + description = "Server does not support keyboard-interactive" + }). %%-------------------------------------------------------------------- @@ -420,10 +420,10 @@ check_password(User, Password, Opts, Ssh) -> {false,NewState} -> {false, Ssh#ssh{pwdfun_user_state=NewState}}; disconnect -> - throw(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = - "Unable to connect using the available authentication methods", - language = ""}) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + description = "Unable to connect using the available authentication methods" + }) end end. diff --git a/lib/ssh/src/ssh_channel.erl b/lib/ssh/src/ssh_channel.erl index de6908bb38..a8e6ebde16 100644 --- a/lib/ssh/src/ssh_channel.erl +++ b/lib/ssh/src/ssh_channel.erl @@ -68,7 +68,7 @@ %% Internal application API -export([cache_create/0, cache_lookup/2, cache_update/2, cache_delete/1, cache_delete/2, cache_foldl/3, - cache_find/2, + cache_info/2, cache_find/2, get_print_info/1]). -record(state, { @@ -335,6 +335,9 @@ cache_delete(Cache) -> cache_foldl(Fun, Acc, Cache) -> ets:foldl(Fun, Acc, Cache). +cache_info(num_entries, Cache) -> + proplists:get_value(size, ets:info(Cache)). + cache_find(ChannelPid, Cache) -> case ets:match_object(Cache, #channel{user = ChannelPid}) of [] -> diff --git a/lib/ssh/src/ssh_connect.hrl b/lib/ssh/src/ssh_connect.hrl index 397d51de9d..4fb6bc39f3 100644 --- a/lib/ssh/src/ssh_connect.hrl +++ b/lib/ssh/src/ssh_connect.hrl @@ -22,13 +22,15 @@ %%% Description : SSH connection protocol --type channel_id() :: integer(). +-type role() :: client | server . +-type connection_ref() :: pid(). +-type channel_id() :: pos_integer(). -define(DEFAULT_PACKET_SIZE, 65536). -define(DEFAULT_WINDOW_SIZE, 10*?DEFAULT_PACKET_SIZE). -define(DEFAULT_TIMEOUT, 5000). --define(MAX_PROTO_VERSION, 255). +-define(MAX_PROTO_VERSION, 255). % Max length of the hello string %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% @@ -241,7 +243,7 @@ -record(channel, { - type, %% "session", "x11", "forwarded-tcpip", "direct-tcpip" + type, %% "session" sys, %% "none", "shell", "exec" "subsystem" user, %% "user" process id (default to cm user) flow_control, diff --git a/lib/ssh/src/ssh_connection.erl b/lib/ssh/src/ssh_connection.erl index a34478732c..d0f2d54c06 100644 --- a/lib/ssh/src/ssh_connection.erl +++ b/lib/ssh/src/ssh_connection.erl @@ -38,8 +38,7 @@ %% Potential API currently unsupported and not tested -export([window_change/4, window_change/6, - direct_tcpip/6, direct_tcpip/8, tcpip_forward/3, - cancel_tcpip_forward/3, signal/3, exit_status/3]). + signal/3, exit_status/3]). %% Internal application API -export([channel_data/5, handle_msg/3, channel_eof_msg/1, @@ -48,7 +47,7 @@ channel_adjust_window_msg/2, channel_data_msg/3, channel_open_msg/5, channel_open_confirmation_msg/4, channel_open_failure_msg/4, channel_request_msg/4, - global_request_msg/3, request_failure_msg/0, + request_failure_msg/0, request_success_msg/1, bind/4, unbind/3, unbind_channel/2, bound_channel/3, encode_ip/1]). @@ -232,52 +231,6 @@ exit_status(ConnectionHandler, Channel, Status) -> ssh_connection_handler:request(ConnectionHandler, Channel, "exit-status", false, [?uint32(Status)], 0). -direct_tcpip(ConnectionHandler, RemoteHost, - RemotePort, OrigIP, OrigPort, Timeout) -> - direct_tcpip(ConnectionHandler, RemoteHost, RemotePort, OrigIP, OrigPort, - ?DEFAULT_WINDOW_SIZE, ?DEFAULT_PACKET_SIZE, Timeout). - -direct_tcpip(ConnectionHandler, RemoteIP, RemotePort, OrigIP, OrigPort, - InitialWindowSize, MaxPacketSize, Timeout) -> - case {encode_ip(RemoteIP), encode_ip(OrigIP)} of - {false, _} -> - {error, einval}; - {_, false} -> - {error, einval}; - {RIP, OIP} -> - ssh_connection_handler:open_channel(ConnectionHandler, - "direct-tcpip", - [?string(RIP), - ?uint32(RemotePort), - ?string(OIP), - ?uint32(OrigPort)], - InitialWindowSize, - MaxPacketSize, - Timeout) - end. - -tcpip_forward(ConnectionHandler, BindIP, BindPort) -> - case encode_ip(BindIP) of - false -> - {error, einval}; - IPStr -> - ssh_connection_handler:global_request(ConnectionHandler, - "tcpip-forward", true, - [?string(IPStr), - ?uint32(BindPort)]) - end. - -cancel_tcpip_forward(ConnectionHandler, BindIP, Port) -> - case encode_ip(BindIP) of - false -> - {error, einval}; - IPStr -> - ssh_connection_handler:global_request(ConnectionHandler, - "cancel-tcpip-forward", true, - [?string(IPStr), - ?uint32(Port)]) - end. - %%-------------------------------------------------------------------- %%% Internal API %%-------------------------------------------------------------------- @@ -300,22 +253,11 @@ l2b([]) -> channel_data(ChannelId, DataType, Data, Connection, From) when is_list(Data)-> - channel_data(ChannelId, DataType, -%% list_to_binary(Data), Connection, From); - l2b(Data), Connection, From); - %% try list_to_binary(Data) - %% of - %% B -> B - %% catch - %% _:_ -> io:format('BAD BINARY: ~p~n',[Data]), - %% unicode:characters_to_binary(Data) - %% end, - %% Connection, From); + channel_data(ChannelId, DataType, l2b(Data), Connection, From); channel_data(ChannelId, DataType, Data, #connection{channel_cache = Cache} = Connection, From) -> - case ssh_channel:cache_lookup(Cache, ChannelId) of #channel{remote_id = Id, sent_close = false} = Channel0 -> {SendList, Channel} = @@ -331,8 +273,7 @@ channel_data(ChannelId, DataType, Data, FlowCtrlMsgs = flow_control(Replies, Channel, Cache), {{replies, Replies ++ FlowCtrlMsgs}, Connection}; _ -> - gen_fsm:reply(From, {error, closed}), - {noreply, Connection} + {{replies,[{channel_request_reply,From,{error,closed}}]}, Connection} end. handle_msg(#ssh_msg_channel_open_confirmation{recipient_channel = ChannelId, @@ -499,7 +440,8 @@ handle_msg(#ssh_msg_channel_open{channel_type = "session" = Type, handle_msg(#ssh_msg_channel_open{channel_type = "session", sender_channel = RemoteId}, - Connection, client) -> + Connection, + client) -> %% Client implementations SHOULD reject any session channel open %% requests to make it more difficult for a corrupt server to attack the %% client. See See RFC 4254 6.1. @@ -509,73 +451,6 @@ handle_msg(#ssh_msg_channel_open{channel_type = "session", {{replies, [{connection_reply, FailMsg}]}, Connection}; -handle_msg(#ssh_msg_channel_open{channel_type = "forwarded-tcpip" = Type, - sender_channel = RemoteId, - initial_window_size = RWindowSz, - maximum_packet_size = RPacketSz, - data = Data}, - #connection{channel_cache = Cache, - options = SSHopts} = Connection0, server) -> - <<?UINT32(ALen), Address:ALen/binary, ?UINT32(Port), - ?UINT32(OLen), Orig:OLen/binary, ?UINT32(OrigPort)>> = Data, - - MinAcceptedPackSz = proplists:get_value(minimal_remote_max_packet_size, SSHopts, 0), - - if - MinAcceptedPackSz =< RPacketSz -> - case bound_channel(Address, Port, Connection0) of - undefined -> - FailMsg = channel_open_failure_msg(RemoteId, - ?SSH_OPEN_CONNECT_FAILED, - "Connection refused", "en"), - {{replies, - [{connection_reply, FailMsg}]}, Connection0}; - ChannelPid -> - {ChannelId, Connection1} = new_channel_id(Connection0), - LWindowSz = ?DEFAULT_WINDOW_SIZE, - LPacketSz = ?DEFAULT_PACKET_SIZE, - Channel = #channel{type = Type, - sys = "none", - user = ChannelPid, - local_id = ChannelId, - recv_window_size = LWindowSz, - recv_packet_size = LPacketSz, - send_window_size = RWindowSz, - send_packet_size = RPacketSz, - send_buf = queue:new() - }, - ssh_channel:cache_update(Cache, Channel), - OpenConfMsg = channel_open_confirmation_msg(RemoteId, ChannelId, - LWindowSz, LPacketSz), - {OpenMsg, Connection} = - reply_msg(Channel, Connection1, - {open, Channel, {forwarded_tcpip, - decode_ip(Address), Port, - decode_ip(Orig), OrigPort}}), - {{replies, [{connection_reply, OpenConfMsg}, - OpenMsg]}, Connection} - end; - - MinAcceptedPackSz > RPacketSz -> - FailMsg = channel_open_failure_msg(RemoteId, - ?SSH_OPEN_ADMINISTRATIVELY_PROHIBITED, - lists:concat(["Maximum packet size below ",MinAcceptedPackSz, - " not supported"]), "en"), - {{replies, [{connection_reply, FailMsg}]}, Connection0} - end; - - -handle_msg(#ssh_msg_channel_open{channel_type = "forwarded-tcpip", - sender_channel = RemoteId}, - Connection, client) -> - %% Client implementations SHOULD reject direct TCP/IP open requests for - %% security reasons. See RFC 4254 7.2. - FailMsg = channel_open_failure_msg(RemoteId, - ?SSH_OPEN_CONNECT_FAILED, - "Connection refused", "en"), - {{replies, [{connection_reply, FailMsg}]}, Connection}; - - handle_msg(#ssh_msg_channel_open{sender_channel = RemoteId}, Connection, _) -> FailMsg = channel_open_failure_msg(RemoteId, ?SSH_OPEN_ADMINISTRATIVELY_PROHIBITED, @@ -786,11 +661,11 @@ handle_msg(#ssh_msg_global_request{name = _Type, handle_msg(#ssh_msg_request_failure{}, #connection{requests = [{_, From} | Rest]} = Connection, _) -> - {{replies, [{channel_requst_reply, From, {failure, <<>>}}]}, + {{replies, [{channel_request_reply, From, {failure, <<>>}}]}, Connection#connection{requests = Rest}}; handle_msg(#ssh_msg_request_success{data = Data}, #connection{requests = [{_, From} | Rest]} = Connection, _) -> - {{replies, [{channel_requst_reply, From, {success, Data}}]}, + {{replies, [{channel_request_reply, From, {success, Data}}]}, Connection#connection{requests = Rest}}; handle_msg(#ssh_msg_disconnect{code = Code, @@ -886,10 +761,6 @@ channel_request_msg(ChannelId, Type, WantReply, Data) -> want_reply = WantReply, data = Data}. -global_request_msg(Type, WantReply, Data) -> - #ssh_msg_global_request{name = Type, - want_reply = WantReply, - data = Data}. request_failure_msg() -> #ssh_msg_request_failure{}. @@ -1059,7 +930,7 @@ request_reply_or_data(#channel{local_id = ChannelId, user = ChannelPid}, Connection, Reply) -> case lists:keysearch(ChannelId, 1, Requests) of {value, {ChannelId, From}} -> - {{channel_requst_reply, From, Reply}, + {{channel_request_reply, From, Reply}, Connection#connection{requests = lists:keydelete(ChannelId, 1, Requests)}}; false when (Reply == success) or (Reply == failure) -> @@ -1351,11 +1222,6 @@ decode_pty_opts2(<<Code, ?UINT32(Value), Tail/binary>>) -> end, [{Op, Value} | decode_pty_opts2(Tail)]. -decode_ip(Addr) when is_binary(Addr) -> - case inet_parse:address(binary_to_list(Addr)) of - {error,_} -> Addr; - {ok,A} -> A - end. backwards_compatible([], Acc) -> Acc; diff --git a/lib/ssh/src/ssh_connection_handler.erl b/lib/ssh/src/ssh_connection_handler.erl index 2bef6a41cd..0327a72c12 100644 --- a/lib/ssh/src/ssh_connection_handler.erl +++ b/lib/ssh/src/ssh_connection_handler.erl @@ -28,94 +28,90 @@ -module(ssh_connection_handler). --behaviour(gen_fsm). +-behaviour(gen_statem). -include("ssh.hrl"). -include("ssh_transport.hrl"). -include("ssh_auth.hrl"). -include("ssh_connect.hrl"). --compile(export_all). --export([start_link/3]). -%% Internal application API --export([open_channel/6, reply_request/3, request/6, request/7, - global_request/4, send/5, send_eof/2, info/1, info/2, - connection_info/2, channel_info/3, - adjust_window/3, close/2, stop/1, renegotiate/1, renegotiate_data/1, - start_connection/4, - get_print_info/1]). - -%% gen_fsm callbacks --export([hello/2, kexinit/2, key_exchange/2, - key_exchange_dh_gex_init/2, key_exchange_dh_gex_reply/2, - new_keys/2, - service_request/2, connected/2, - userauth/2, - userauth_keyboard_interactive/2, - userauth_keyboard_interactive_info_response/2, - error/2]). - --export([init/1, handle_event/3, - handle_sync_event/4, handle_info/3, terminate/3, format_status/2, code_change/4]). - --record(state, { - role, - client, - starter, - auth_user, - connection_state, - latest_channel_id = 0, - idle_timer_ref, - transport_protocol, % ex: tcp - transport_cb, - transport_close_tag, - ssh_params, % #ssh{} - from ssh.hrl - socket, % socket() - decoded_data_buffer, % binary() - encoded_data_buffer, % binary() - undecoded_packet_length, % integer() - key_exchange_init_msg, % #ssh_msg_kexinit{} - renegotiate = false, % boolean() - last_size_rekey = 0, - event_queue = [], - connection_queue, - address, - port, - opts, - recbuf - }). - --type state_name() :: hello | kexinit | key_exchange | key_exchange_dh_gex_init | - key_exchange_dh_gex_reply | new_keys | service_request | - userauth | userauth_keyboard_interactive | - userauth_keyboard_interactive_info_response | - connection. - --type gen_fsm_state_return() :: {next_state, state_name(), term()} | - {next_state, state_name(), term(), timeout()} | - {stop, term(), term()}. - --type gen_fsm_sync_return() :: {next_state, state_name(), term()} | - {next_state, state_name(), term(), timeout()} | - {reply, term(), state_name(), term()} | - {stop, term(), term(), term()}. +%%==================================================================== +%%% Exports +%%==================================================================== + +%%% Start and stop +-export([start_link/3, + stop/1 + ]). + +%%% Internal application API +-export([start_connection/4, + open_channel/6, + request/6, request/7, + reply_request/3, + send/5, + send_eof/2, + info/1, info/2, + connection_info/2, + channel_info/3, + adjust_window/3, close/2, + disconnect/1, disconnect/2, + get_print_info/1 + ]). + +%%% Behaviour callbacks +-export([handle_event/4, terminate/3, format_status/2, code_change/4]). + +%%% Exports not intended to be used :). They are used for spawning and tests +-export([init_connection_handler/3, % proc_lib:spawn needs this + init_ssh_record/3, % Export of this internal function + % intended for low-level protocol test suites + renegotiate/1, renegotiate_data/1 % Export intended for test cases + ]). %%==================================================================== -%% Internal application API +%% Start / stop %%==================================================================== +%%-------------------------------------------------------------------- +-spec start_link(role(), + inet:socket(), + proplists:proplist() + ) -> {ok, pid()}. +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . +start_link(Role, Socket, Options) -> + {ok, proc_lib:spawn_link(?MODULE, init_connection_handler, [Role, Socket, Options])}. + %%-------------------------------------------------------------------- --spec start_connection(client| server, port(), proplists:proplist(), - timeout()) -> {ok, pid()} | {error, term()}. +-spec stop(connection_ref() + ) -> ok | {error, term()}. +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . +stop(ConnectionHandler)-> + case call(ConnectionHandler, stop) of + {error, closed} -> + ok; + Other -> + Other + end. + +%%==================================================================== +%% Internal application API +%%==================================================================== + +-define(DefaultTransport, {tcp, gen_tcp, tcp_closed} ). + %%-------------------------------------------------------------------- +-spec start_connection(role(), + inet:socket(), + proplists:proplist(), + timeout() + ) -> {ok, connection_ref()} | {error, term()}. +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . start_connection(client = Role, Socket, Options, Timeout) -> try {ok, Pid} = sshc_sup:start_child([Role, Socket, Options]), - {_, Callback, _} = - proplists:get_value(transport, Options, {tcp, gen_tcp, tcp_closed}), - ok = socket_control(Socket, Pid, Callback), - Ref = erlang:monitor(process, Pid), - handshake(Pid, Ref, Timeout) + ok = socket_control(Socket, Pid, Options), + handshake(Pid, erlang:monitor(process,Pid), Timeout) catch exit:{noproc, _} -> {error, ssh_not_started}; @@ -128,8 +124,8 @@ start_connection(server = Role, Socket, Options, Timeout) -> try case proplists:get_value(parallel_login, SSH_Opts, false) of true -> - HandshakerPid = - spawn_link(fun() -> + HandshakerPid = + spawn_link(fun() -> receive {do_handshake, Pid} -> handshake(Pid, erlang:monitor(process,Pid), Timeout) @@ -148,953 +144,1123 @@ start_connection(server = Role, Socket, Options, Timeout) -> {error, Error} end. -start_the_connection_child(UserPid, Role, Socket, Options) -> - Sups = proplists:get_value(supervisors, Options), - ConnectionSup = proplists:get_value(connection_sup, Sups), - Opts = [{supervisors, Sups}, {user_pid, UserPid} | proplists:get_value(ssh_opts, Options, [])], - {ok, Pid} = ssh_connection_sup:start_child(ConnectionSup, [Role, Socket, Opts]), - {_, Callback, _} = proplists:get_value(transport, Options, {tcp, gen_tcp, tcp_closed}), - socket_control(Socket, Pid, Callback), - Pid. - +%%-------------------------------------------------------------------- +%%% Some other module has decided to disconnect. +-spec disconnect(#ssh_msg_disconnect{}) -> no_return(). +-spec disconnect(#ssh_msg_disconnect{}, iodata()) -> no_return(). +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . +disconnect(Msg = #ssh_msg_disconnect{}) -> + throw({keep_state_and_data, + [{next_event, internal, {disconnect, Msg, Msg#ssh_msg_disconnect.description}}]}). -start_link(Role, Socket, Options) -> - {ok, proc_lib:spawn_link(?MODULE, init, [[Role, Socket, Options]])}. +disconnect(Msg = #ssh_msg_disconnect{}, ExtraInfo) -> + throw({keep_state_and_data, + [{next_event, internal, {disconnect, Msg, {Msg#ssh_msg_disconnect.description,ExtraInfo}}}]}). -init([Role, Socket, SshOpts]) -> - process_flag(trap_exit, true), - {NumVsn, StrVsn} = ssh_transport:versions(Role, SshOpts), - {Protocol, Callback, CloseTag} = - proplists:get_value(transport, SshOpts, {tcp, gen_tcp, tcp_closed}), - Cache = ssh_channel:cache_create(), - State0 = #state{ - role = Role, - connection_state = #connection{channel_cache = Cache, - channel_id_seed = 0, - port_bindings = [], - requests = [], - options = SshOpts}, - socket = Socket, - decoded_data_buffer = <<>>, - encoded_data_buffer = <<>>, - transport_protocol = Protocol, - transport_cb = Callback, - transport_close_tag = CloseTag, - opts = SshOpts - }, - - State = init_role(State0), - - try init_ssh(Role, NumVsn, StrVsn, SshOpts, Socket) of - Ssh -> - gen_fsm:enter_loop(?MODULE, [], hello, - State#state{ssh_params = Ssh}) - catch - _:Error -> - gen_fsm:enter_loop(?MODULE, [], error, {Error, State}) - end. -%% Temporary fix for the Nessus error. SYN-> <-SYNACK ACK-> RST-> ? -error(_Event, {Error,State=#state{}}) -> - case Error of - {badmatch,{error,enotconn}} -> - %% {error,enotconn} probably from inet:peername in - %% init_ssh(server,..)/5 called from init/1 - {stop, {shutdown,"TCP connenction to server was prematurely closed by the client"}, State}; - _ -> - {stop, {shutdown,{init,Error}}, State} - end; -error(Event, State) -> - %% State deliberately not checked beeing #state. This is a panic-clause... - {stop, {shutdown,{init,{spurious_error,Event}}}, State}. - -%%-------------------------------------------------------------------- --spec open_channel(pid(), string(), iodata(), integer(), integer(), - timeout()) -> {open, channel_id()} | {error, term()}. %%-------------------------------------------------------------------- -open_channel(ConnectionHandler, ChannelType, ChannelSpecificData, - InitialWindowSize, - MaxPacketSize, Timeout) -> - sync_send_all_state_event(ConnectionHandler, {open, self(), ChannelType, - InitialWindowSize, MaxPacketSize, - ChannelSpecificData, - Timeout}). -%%-------------------------------------------------------------------- --spec request(pid(), pid(), channel_id(), string(), boolean(), iodata(), - timeout()) -> success | failure | ok | {error, term()}. +-spec open_channel(connection_ref(), + string(), + iodata(), + pos_integer(), + pos_integer(), + timeout() + ) -> {open, channel_id()} | {error, term()}. + +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . +open_channel(ConnectionHandler, + ChannelType, ChannelSpecificData, InitialWindowSize, MaxPacketSize, + Timeout) -> + call(ConnectionHandler, + {open, + self(), + ChannelType, InitialWindowSize, MaxPacketSize, ChannelSpecificData, + Timeout}). + %%-------------------------------------------------------------------- +-spec request(connection_ref(), + pid(), + channel_id(), + string(), + boolean(), + iodata(), + timeout() + ) -> success | failure | ok | {error,timeout}. + +-spec request(connection_ref(), + channel_id(), + string(), + boolean(), + iodata(), + timeout() + ) -> success | failure | ok | {error,timeout}. +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . request(ConnectionHandler, ChannelPid, ChannelId, Type, true, Data, Timeout) -> - sync_send_all_state_event(ConnectionHandler, {request, ChannelPid, ChannelId, Type, Data, - Timeout}); + call(ConnectionHandler, {request, ChannelPid, ChannelId, Type, Data, Timeout}); request(ConnectionHandler, ChannelPid, ChannelId, Type, false, Data, _) -> - send_all_state_event(ConnectionHandler, {request, ChannelPid, ChannelId, Type, Data}). + cast(ConnectionHandler, {request, ChannelPid, ChannelId, Type, Data}). -%%-------------------------------------------------------------------- --spec request(pid(), channel_id(), string(), boolean(), iodata(), - timeout()) -> success | failure | {error, timeout}. -%%-------------------------------------------------------------------- request(ConnectionHandler, ChannelId, Type, true, Data, Timeout) -> - sync_send_all_state_event(ConnectionHandler, {request, ChannelId, Type, Data, Timeout}); + call(ConnectionHandler, {request, ChannelId, Type, Data, Timeout}); request(ConnectionHandler, ChannelId, Type, false, Data, _) -> - send_all_state_event(ConnectionHandler, {request, ChannelId, Type, Data}). + cast(ConnectionHandler, {request, ChannelId, Type, Data}). %%-------------------------------------------------------------------- --spec reply_request(pid(), success | failure, channel_id()) -> ok. -%%-------------------------------------------------------------------- +-spec reply_request(connection_ref(), + success | failure, + channel_id() + ) -> ok. + +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . reply_request(ConnectionHandler, Status, ChannelId) -> - send_all_state_event(ConnectionHandler, {reply_request, Status, ChannelId}). - -%%-------------------------------------------------------------------- --spec global_request(pid(), string(), boolean(), iolist()) -> ok | error. -%%-------------------------------------------------------------------- -global_request(ConnectionHandler, Type, true = Reply, Data) -> - case sync_send_all_state_event(ConnectionHandler, - {global_request, self(), Type, Reply, Data}) of - {ssh_cm, ConnectionHandler, {success, _}} -> - ok; - {ssh_cm, ConnectionHandler, {failure, _}} -> - error - end; -global_request(ConnectionHandler, Type, false = Reply, Data) -> - send_all_state_event(ConnectionHandler, {global_request, self(), Type, Reply, Data}). + cast(ConnectionHandler, {reply_request, Status, ChannelId}). %%-------------------------------------------------------------------- --spec send(pid(), channel_id(), integer(), iodata(), timeout()) -> - ok | {error, timeout} | {error, closed}. -%%-------------------------------------------------------------------- +-spec send(connection_ref(), + channel_id(), + non_neg_integer(), + iodata(), + timeout() + ) -> ok | {error, timeout|closed}. +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . send(ConnectionHandler, ChannelId, Type, Data, Timeout) -> - sync_send_all_state_event(ConnectionHandler, {data, ChannelId, Type, Data, Timeout}). + call(ConnectionHandler, {data, ChannelId, Type, Data, Timeout}). %%-------------------------------------------------------------------- --spec send_eof(pid(), channel_id()) -> ok | {error, closed}. -%%-------------------------------------------------------------------- +-spec send_eof(connection_ref(), + channel_id() + ) -> ok | {error,closed}. +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . send_eof(ConnectionHandler, ChannelId) -> - sync_send_all_state_event(ConnectionHandler, {eof, ChannelId}). + call(ConnectionHandler, {eof, ChannelId}). %%-------------------------------------------------------------------- --spec connection_info(pid(), [atom()]) -> proplists:proplist(). +-spec info(connection_ref() + ) -> {ok, [#channel{}]} . + +-spec info(connection_ref(), + pid() | all + ) -> {ok, [#channel{}]} . +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . +info(ConnectionHandler) -> + info(ConnectionHandler, all). + +info(ConnectionHandler, ChannelProcess) -> + call(ConnectionHandler, {info, ChannelProcess}). + %%-------------------------------------------------------------------- +-type local_sock_info() :: {inet:ip_address(), non_neg_integer()} | string(). +-type peer_sock_info() :: {inet:ip_address(), non_neg_integer()} | string(). +-type state_info() :: iolist(). + +-spec get_print_info(connection_ref() + ) -> {{local_sock_info(), peer_sock_info()}, + state_info() + }. +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . get_print_info(ConnectionHandler) -> - sync_send_all_state_event(ConnectionHandler, get_print_info, 1000). + call(ConnectionHandler, get_print_info, 1000). +%%-------------------------------------------------------------------- +-spec connection_info(connection_ref(), + [atom()] + ) -> proplists:proplist(). +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . connection_info(ConnectionHandler, Options) -> - sync_send_all_state_event(ConnectionHandler, {connection_info, Options}). + call(ConnectionHandler, {connection_info, Options}). %%-------------------------------------------------------------------- --spec channel_info(pid(), channel_id(), [atom()]) -> proplists:proplist(). -%%-------------------------------------------------------------------- +-spec channel_info(connection_ref(), + channel_id(), + [atom()] + ) -> proplists:proplist(). +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . channel_info(ConnectionHandler, ChannelId, Options) -> - sync_send_all_state_event(ConnectionHandler, {channel_info, ChannelId, Options}). + call(ConnectionHandler, {channel_info, ChannelId, Options}). %%-------------------------------------------------------------------- --spec adjust_window(pid(), channel_id(), integer()) -> ok. -%%-------------------------------------------------------------------- +-spec adjust_window(connection_ref(), + channel_id(), + integer() + ) -> ok. +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . adjust_window(ConnectionHandler, Channel, Bytes) -> - send_all_state_event(ConnectionHandler, {adjust_window, Channel, Bytes}). -%%-------------------------------------------------------------------- --spec renegotiate(pid()) -> ok. -%%-------------------------------------------------------------------- -renegotiate(ConnectionHandler) -> - send_all_state_event(ConnectionHandler, renegotiate). - -%%-------------------------------------------------------------------- --spec renegotiate_data(pid()) -> ok. -%%-------------------------------------------------------------------- -renegotiate_data(ConnectionHandler) -> - send_all_state_event(ConnectionHandler, data_size). + cast(ConnectionHandler, {adjust_window, Channel, Bytes}). %%-------------------------------------------------------------------- --spec close(pid(), channel_id()) -> ok. -%%-------------------------------------------------------------------- +-spec close(connection_ref(), + channel_id() + ) -> ok. +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . close(ConnectionHandler, ChannelId) -> - case sync_send_all_state_event(ConnectionHandler, {close, ChannelId}) of + case call(ConnectionHandler, {close, ChannelId}) of ok -> ok; - {error, closed} -> + {error, closed} -> ok - end. - -%%-------------------------------------------------------------------- --spec stop(pid()) -> ok | {error, term()}. -%%-------------------------------------------------------------------- -stop(ConnectionHandler)-> - case sync_send_all_state_event(ConnectionHandler, stop) of - {error, closed} -> - ok; - Other -> - Other end. -info(ConnectionHandler) -> - info(ConnectionHandler, {info, all}). +%%==================================================================== +%% Test support +%%==================================================================== +%%-------------------------------------------------------------------- +-spec renegotiate(connection_ref() + ) -> ok. +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . +renegotiate(ConnectionHandler) -> + cast(ConnectionHandler, renegotiate). -info(ConnectionHandler, ChannelProcess) -> - sync_send_all_state_event(ConnectionHandler, {info, ChannelProcess}). +%%-------------------------------------------------------------------- +-spec renegotiate_data(connection_ref() + ) -> ok. +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . +renegotiate_data(ConnectionHandler) -> + cast(ConnectionHandler, data_size). %%==================================================================== -%% gen_fsm callbacks +%% Internal process state %%==================================================================== +-record(data, { + starter :: pid(), + auth_user :: string() + | undefined, + connection_state :: #connection{}, + latest_channel_id = 0 :: non_neg_integer(), + idle_timer_ref :: undefined + | infinity + | reference(), + idle_timer_value = infinity :: infinity + | pos_integer(), + transport_protocol :: atom(), % ex: tcp + transport_cb :: atom(), % ex: gen_tcp + transport_close_tag :: atom(), % ex: tcp_closed + ssh_params :: #ssh{} + | undefined, + socket :: inet:socket(), + decrypted_data_buffer = <<>> :: binary(), + encrypted_data_buffer = <<>> :: binary(), + undecrypted_packet_length :: undefined | non_neg_integer(), + key_exchange_init_msg :: #ssh_msg_kexinit{} + | undefined, + last_size_rekey = 0 :: non_neg_integer(), + event_queue = [] :: list(), + opts :: proplists:proplist(), + inet_initial_recbuf_size :: pos_integer() + | undefined + }). +%%==================================================================== +%% Intitialisation +%%==================================================================== %%-------------------------------------------------------------------- --spec hello(socket_control | {info_line, list()} | {version_exchange, list()}, - #state{}) -> gen_fsm_state_return(). +-spec init_connection_handler(role(), + inet:socket(), + proplists:proplist() + ) -> no_return(). +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . +init_connection_handler(Role, Socket, Opts) -> + process_flag(trap_exit, true), + S0 = init_process_state(Role, Socket, Opts), + try + {Protocol, Callback, CloseTag} = + proplists:get_value(transport, Opts, ?DefaultTransport), + S0#data{ssh_params = init_ssh_record(Role, Socket, Opts), + transport_protocol = Protocol, + transport_cb = Callback, + transport_close_tag = CloseTag + } + of + S -> + gen_statem:enter_loop(?MODULE, + [], %%[{debug,[trace,log,statistics,debug]} || Role==server], + handle_event_function, + {hello,Role}, + S) + catch + _:Error -> + gen_statem:enter_loop(?MODULE, + [], + handle_event_function, + {init_error,Error}, + S0) + end. + + +init_process_state(Role, Socket, Opts) -> + D = #data{connection_state = + C = #connection{channel_cache = ssh_channel:cache_create(), + channel_id_seed = 0, + port_bindings = [], + requests = [], + options = Opts}, + starter = proplists:get_value(user_pid, Opts), + socket = Socket, + opts = Opts + }, + case Role of + client -> + %% Start the renegotiation timers + timer:apply_after(?REKEY_TIMOUT, gen_statem, cast, [self(), renegotiate]), + timer:apply_after(?REKEY_DATA_TIMOUT, gen_statem, cast, [self(), data_size]), + cache_init_idle_timer(D); + server -> + D#data{connection_state = init_connection(Role, C, Opts)} + end. + + +init_connection(server, C = #connection{}, Opts) -> + Sups = proplists:get_value(supervisors, Opts), + SystemSup = proplists:get_value(system_sup, Sups), + SubSystemSup = proplists:get_value(subsystem_sup, Sups), + ConnectionSup = proplists:get_value(connection_sup, Sups), + Shell = proplists:get_value(shell, Opts), + Exec = proplists:get_value(exec, Opts), + CliSpec = proplists:get_value(ssh_cli, Opts, {ssh_cli, [Shell]}), + C#connection{cli_spec = CliSpec, + exec = Exec, + system_supervisor = SystemSup, + sub_system_supervisor = SubSystemSup, + connection_supervisor = ConnectionSup + }. + + +init_ssh_record(Role, Socket, Opts) -> + {ok, PeerAddr} = inet:peername(Socket), + KeyCb = proplists:get_value(key_cb, Opts, ssh_file), + AuthMethods = proplists:get_value(auth_methods, Opts, ?SUPPORTED_AUTH_METHODS), + S0 = #ssh{role = Role, + key_cb = KeyCb, + opts = Opts, + userauth_supported_methods = AuthMethods, + available_host_keys = supported_host_keys(Role, KeyCb, Opts), + random_length_padding = proplists:get_value(max_random_length_padding, + Opts, + (#ssh{})#ssh.random_length_padding) + }, + + {Vsn, Version} = ssh_transport:versions(Role, Opts), + case Role of + client -> + PeerName = proplists:get_value(host, Opts), + S0#ssh{c_vsn = Vsn, + c_version = Version, + io_cb = case proplists:get_value(user_interaction, Opts, true) of + true -> ssh_io; + false -> ssh_no_io + end, + userauth_quiet_mode = proplists:get_value(quiet_mode, Opts, false), + peer = {PeerName, PeerAddr} + }; + + server -> + S0#ssh{s_vsn = Vsn, + s_version = Version, + io_cb = proplists:get_value(io_cb, Opts, ssh_io), + userauth_methods = string:tokens(AuthMethods, ","), + kb_tries_left = 3, + peer = {undefined, PeerAddr} + } + end. + + + +%%==================================================================== +%% gen_statem callbacks +%%==================================================================== %%-------------------------------------------------------------------- +-type event_content() :: any(). + +-type renegotiate_flag() :: init | renegotiate. + +-type state_name() :: + {init_error,any()} + | {hello, role()} + | {kexinit, role(), renegotiate_flag()} + | {key_exchange, role(), renegotiate_flag()} + | {key_exchange_dh_gex_init, server, renegotiate_flag()} + | {key_exchange_dh_gex_reply, client, renegotiate_flag()} + | {new_keys, role()} + | {service_request, role()} + | {userauth, role()} + | {userauth_keyboard_interactive, role()} + | {connected, role()} + . + +-type handle_event_result() :: gen_statem:handle_event_result(). + +-spec handle_event(gen_statem:event_type(), + event_content(), + state_name(), + #data{} + ) -> handle_event_result(). + +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +%%% ######## Error in the initialisation #### + +handle_event(_, _Event, {init_error,Error}, _) -> + case Error of + {badmatch,{error,enotconn}} -> + %% Handles the abnormal sequence: + %% SYN-> + %% <-SYNACK + %% ACK-> + %% RST-> + {stop, {shutdown,"TCP connenction to server was prematurely closed by the client"}}; + + OtherError -> + {stop, {shutdown,{init,OtherError}}} + end; -hello(socket_control, #state{socket = Socket, ssh_params = Ssh} = State) -> - VsnMsg = ssh_transport:hello_version_msg(string_version(Ssh)), - send_msg(VsnMsg, State), - case getopt(recbuf, Socket) of - {ok, Size} -> - inet:setopts(Socket, [{packet, line}, {active, once}, {recbuf, ?MAX_PROTO_VERSION}]), - {next_state, hello, State#state{recbuf = Size}}; - {error, Reason} -> - {stop, {shutdown, Reason}, State} + +%%% ######## {hello, client|server} #### +%% The very first event that is sent when the we are set as controlling process of Socket +handle_event(_, socket_control, {hello,_}, D) -> + VsnMsg = ssh_transport:hello_version_msg(string_version(D#data.ssh_params)), + ok = send_bytes(VsnMsg, D), + case inet:getopts(Socket=D#data.socket, [recbuf]) of + {ok, [{recbuf,Size}]} -> + %% Set the socket to the hello text line handling mode: + inet:setopts(Socket, [{packet, line}, + {active, once}, + % Expecting the version string which might + % be max ?MAX_PROTO_VERSION bytes: + {recbuf, ?MAX_PROTO_VERSION}, + {nodelay,true}]), + {keep_state, D#data{inet_initial_recbuf_size=Size}}; + + Other -> + {stop, {shutdown,{unexpected_getopts_return, Other}}} end; -hello({info_line, _Line},#state{role = client, socket = Socket} = State) -> - %% The server may send info lines before the version_exchange - inet:setopts(Socket, [{active, once}]), - {next_state, hello, State}; - -hello({info_line, _Line},#state{role = server, - socket = Socket, - transport_cb = Transport } = State) -> - %% as openssh - Transport:send(Socket, "Protocol mismatch."), - {stop, {shutdown,"Protocol mismatch in version exchange."}, State}; - -hello({version_exchange, Version}, #state{ssh_params = Ssh0, - socket = Socket, - recbuf = Size} = State) -> +handle_event(_, {info_line,_Line}, {hello,Role}, D) -> + case Role of + client -> + %% The server may send info lines to the client before the version_exchange + inet:setopts(D#data.socket, [{active, once}]), + keep_state_and_data; + server -> + %% But the client may NOT send them to the server. Openssh answers with cleartext, + %% and so do we + ok = send_bytes("Protocol mismatch.", D), + {stop, {shutdown,"Protocol mismatch in version exchange. Client sent info lines."}} + end; + +handle_event(_, {version_exchange,Version}, {hello,Role}, D) -> {NumVsn, StrVsn} = ssh_transport:handle_hello_version(Version), - case handle_version(NumVsn, StrVsn, Ssh0) of + case handle_version(NumVsn, StrVsn, D#data.ssh_params) of {ok, Ssh1} -> - inet:setopts(Socket, [{packet,0}, {mode,binary}, {active, once}, {recbuf, Size}]), + %% Since the hello part is finnished correctly, we set the + %% socket to the packet handling mode (including recbuf size): + inet:setopts(D#data.socket, [{packet,0}, + {mode,binary}, + {active, once}, + {recbuf, D#data.inet_initial_recbuf_size}]), {KeyInitMsg, SshPacket, Ssh} = ssh_transport:key_exchange_init_msg(Ssh1), - send_msg(SshPacket, State), - {next_state, kexinit, next_packet(State#state{ssh_params = Ssh, - key_exchange_init_msg = - KeyInitMsg})}; + ok = send_bytes(SshPacket, D), + {next_state, {kexinit,Role,init}, D#data{ssh_params = Ssh, + key_exchange_init_msg = KeyInitMsg}}; not_supported -> - DisconnectMsg = - #ssh_msg_disconnect{code = - ?SSH_DISCONNECT_PROTOCOL_VERSION_NOT_SUPPORTED, - description = "Protocol version " ++ StrVsn - ++ " not supported", - language = "en"}, - handle_disconnect(DisconnectMsg, State) - end. + disconnect( + #ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_VERSION_NOT_SUPPORTED, + description = ["Protocol version ",StrVsn," not supported"]}, + {next_state, {hello,Role}, D}) + end; -%%-------------------------------------------------------------------- --spec kexinit({#ssh_msg_kexinit{}, binary()}, #state{}) -> gen_fsm_state_return(). -%%-------------------------------------------------------------------- -kexinit({#ssh_msg_kexinit{} = Kex, Payload}, - #state{ssh_params = #ssh{role = Role} = Ssh0, - key_exchange_init_msg = OwnKex} = - State) -> - Ssh1 = ssh_transport:key_init(opposite_role(Role), Ssh0, Payload), - case ssh_transport:handle_kexinit_msg(Kex, OwnKex, Ssh1) of - {ok, NextKexMsg, Ssh} when Role == client -> - send_msg(NextKexMsg, State), - {next_state, key_exchange, - next_packet(State#state{ssh_params = Ssh})}; - {ok, Ssh} when Role == server -> - {next_state, key_exchange, - next_packet(State#state{ssh_params = Ssh})} - end. + +%%% ######## {kexinit, client|server, init|renegotiate} #### -%%-------------------------------------------------------------------- --spec key_exchange(#ssh_msg_kexdh_init{} | #ssh_msg_kexdh_reply{} | - #ssh_msg_kex_dh_gex_group{} | #ssh_msg_kex_dh_gex_request{} | - #ssh_msg_kex_dh_gex_request{} | #ssh_msg_kex_dh_gex_reply{}, #state{}) - -> gen_fsm_state_return(). -%%-------------------------------------------------------------------- +handle_event(_, {#ssh_msg_kexinit{}=Kex, Payload}, {kexinit,Role,ReNeg}, + D = #data{key_exchange_init_msg = OwnKex}) -> + Ssh1 = ssh_transport:key_init(peer_role(Role), D#data.ssh_params, Payload), + Ssh = case ssh_transport:handle_kexinit_msg(Kex, OwnKex, Ssh1) of + {ok, NextKexMsg, Ssh2} when Role==client -> + ok = send_bytes(NextKexMsg, D), + Ssh2; + {ok, Ssh2} when Role==server -> + Ssh2 + end, + {next_state, {key_exchange,Role,ReNeg}, D#data{ssh_params=Ssh}}; -key_exchange(#ssh_msg_kexdh_init{} = Msg, - #state{ssh_params = #ssh{role = server} = Ssh0} = State) -> - case ssh_transport:handle_kexdh_init(Msg, Ssh0) of - {ok, KexdhReply, Ssh1} -> - send_msg(KexdhReply, State), - {ok, NewKeys, Ssh} = ssh_transport:new_keys_message(Ssh1), - send_msg(NewKeys, State), - {next_state, new_keys, next_packet(State#state{ssh_params = Ssh})} - end; -key_exchange(#ssh_msg_kexdh_reply{} = Msg, - #state{ssh_params = #ssh{role = client} = Ssh0} = State) -> - {ok, NewKeys, Ssh} = ssh_transport:handle_kexdh_reply(Msg, Ssh0), - send_msg(NewKeys, State), - {next_state, new_keys, next_packet(State#state{ssh_params = Ssh})}; - -key_exchange(#ssh_msg_kex_dh_gex_request{} = Msg, - #state{ssh_params = #ssh{role = server} = Ssh0} = State) -> - {ok, GexGroup, Ssh} = ssh_transport:handle_kex_dh_gex_request(Msg, Ssh0), - send_msg(GexGroup, State), - {next_state, key_exchange_dh_gex_init, next_packet(State#state{ssh_params = Ssh})}; - -key_exchange(#ssh_msg_kex_dh_gex_request_old{} = Msg, - #state{ssh_params = #ssh{role = server} = Ssh0} = State) -> - {ok, GexGroup, Ssh} = ssh_transport:handle_kex_dh_gex_request(Msg, Ssh0), - send_msg(GexGroup, State), - {next_state, key_exchange_dh_gex_init, next_packet(State#state{ssh_params = Ssh})}; - -key_exchange(#ssh_msg_kex_dh_gex_group{} = Msg, - #state{ssh_params = #ssh{role = client} = Ssh0} = State) -> - {ok, KexGexInit, Ssh} = ssh_transport:handle_kex_dh_gex_group(Msg, Ssh0), - send_msg(KexGexInit, State), - {next_state, key_exchange_dh_gex_reply, next_packet(State#state{ssh_params = Ssh})}; - -key_exchange(#ssh_msg_kex_ecdh_init{} = Msg, - #state{ssh_params = #ssh{role = server} = Ssh0} = State) -> - {ok, KexEcdhReply, Ssh1} = ssh_transport:handle_kex_ecdh_init(Msg, Ssh0), - send_msg(KexEcdhReply, State), +%%% ######## {key_exchange, client|server, init|renegotiate} #### + +%%%---- diffie-hellman +handle_event(_, #ssh_msg_kexdh_init{} = Msg, {key_exchange,server,ReNeg}, D) -> + {ok, KexdhReply, Ssh1} = ssh_transport:handle_kexdh_init(Msg, D#data.ssh_params), + ok = send_bytes(KexdhReply, D), + {ok, NewKeys, Ssh} = ssh_transport:new_keys_message(Ssh1), + ok = send_bytes(NewKeys, D), + {next_state, {new_keys,server,ReNeg}, D#data{ssh_params=Ssh}}; + +handle_event(_, #ssh_msg_kexdh_reply{} = Msg, {key_exchange,client,ReNeg}, D) -> + {ok, NewKeys, Ssh} = ssh_transport:handle_kexdh_reply(Msg, D#data.ssh_params), + ok = send_bytes(NewKeys, D), + {next_state, {new_keys,client,ReNeg}, D#data{ssh_params=Ssh}}; + +%%%---- diffie-hellman group exchange +handle_event(_, #ssh_msg_kex_dh_gex_request{} = Msg, {key_exchange,server,ReNeg}, D) -> + {ok, GexGroup, Ssh} = ssh_transport:handle_kex_dh_gex_request(Msg, D#data.ssh_params), + ok = send_bytes(GexGroup, D), + {next_state, {key_exchange_dh_gex_init,server,ReNeg}, D#data{ssh_params=Ssh}}; + +handle_event(_, #ssh_msg_kex_dh_gex_request_old{} = Msg, {key_exchange,server,ReNeg}, D) -> + {ok, GexGroup, Ssh} = ssh_transport:handle_kex_dh_gex_request(Msg, D#data.ssh_params), + ok = send_bytes(GexGroup, D), + {next_state, {key_exchange_dh_gex_init,server,ReNeg}, D#data{ssh_params=Ssh}}; + +handle_event(_, #ssh_msg_kex_dh_gex_group{} = Msg, {key_exchange,client,ReNeg}, D) -> + {ok, KexGexInit, Ssh} = ssh_transport:handle_kex_dh_gex_group(Msg, D#data.ssh_params), + ok = send_bytes(KexGexInit, D), + {next_state, {key_exchange_dh_gex_reply,client,ReNeg}, D#data{ssh_params=Ssh}}; + +%%%---- elliptic curve diffie-hellman +handle_event(_, #ssh_msg_kex_ecdh_init{} = Msg, {key_exchange,server,ReNeg}, D) -> + {ok, KexEcdhReply, Ssh1} = ssh_transport:handle_kex_ecdh_init(Msg, D#data.ssh_params), + ok = send_bytes(KexEcdhReply, D), {ok, NewKeys, Ssh} = ssh_transport:new_keys_message(Ssh1), - send_msg(NewKeys, State), - {next_state, new_keys, next_packet(State#state{ssh_params = Ssh})}; + ok = send_bytes(NewKeys, D), + {next_state, {new_keys,server,ReNeg}, D#data{ssh_params=Ssh}}; -key_exchange(#ssh_msg_kex_ecdh_reply{} = Msg, - #state{ssh_params = #ssh{role = client} = Ssh0} = State) -> - {ok, NewKeys, Ssh} = ssh_transport:handle_kex_ecdh_reply(Msg, Ssh0), - send_msg(NewKeys, State), - {next_state, new_keys, next_packet(State#state{ssh_params = Ssh})}. +handle_event(_, #ssh_msg_kex_ecdh_reply{} = Msg, {key_exchange,client,ReNeg}, D) -> + {ok, NewKeys, Ssh} = ssh_transport:handle_kex_ecdh_reply(Msg, D#data.ssh_params), + ok = send_bytes(NewKeys, D), + {next_state, {new_keys,client,ReNeg}, D#data{ssh_params=Ssh}}; -%%-------------------------------------------------------------------- --spec key_exchange_dh_gex_init(#ssh_msg_kex_dh_gex_init{}, #state{}) -> gen_fsm_state_return(). -%%-------------------------------------------------------------------- -key_exchange_dh_gex_init(#ssh_msg_kex_dh_gex_init{} = Msg, - #state{ssh_params = #ssh{role = server} = Ssh0} = State) -> - {ok, KexGexReply, Ssh1} = ssh_transport:handle_kex_dh_gex_init(Msg, Ssh0), - send_msg(KexGexReply, State), + +%%% ######## {key_exchange_dh_gex_init, server, init|renegotiate} #### + +handle_event(_, #ssh_msg_kex_dh_gex_init{} = Msg, {key_exchange_dh_gex_init,server,ReNeg}, D) -> + {ok, KexGexReply, Ssh1} = ssh_transport:handle_kex_dh_gex_init(Msg, D#data.ssh_params), + ok = send_bytes(KexGexReply, D), {ok, NewKeys, Ssh} = ssh_transport:new_keys_message(Ssh1), - send_msg(NewKeys, State), - {next_state, new_keys, next_packet(State#state{ssh_params = Ssh})}. + ok = send_bytes(NewKeys, D), + {next_state, {new_keys,server,ReNeg}, D#data{ssh_params=Ssh}}; -%%-------------------------------------------------------------------- --spec key_exchange_dh_gex_reply(#ssh_msg_kex_dh_gex_reply{}, #state{}) -> gen_fsm_state_return(). -%%-------------------------------------------------------------------- -key_exchange_dh_gex_reply(#ssh_msg_kex_dh_gex_reply{} = Msg, - #state{ssh_params = #ssh{role = client} = Ssh0} = State) -> - {ok, NewKeys, Ssh1} = ssh_transport:handle_kex_dh_gex_reply(Msg, Ssh0), - send_msg(NewKeys, State), - {next_state, new_keys, next_packet(State#state{ssh_params = Ssh1})}. -%%-------------------------------------------------------------------- --spec new_keys(#ssh_msg_newkeys{}, #state{}) -> gen_fsm_state_return(). -%%-------------------------------------------------------------------- +%%% ######## {key_exchange_dh_gex_reply, client, init|renegotiate} #### -new_keys(#ssh_msg_newkeys{} = Msg, #state{ssh_params = Ssh0} = State0) -> - {ok, Ssh} = ssh_transport:handle_new_keys(Msg, Ssh0), - after_new_keys(next_packet(State0#state{ssh_params = Ssh})). +handle_event(_, #ssh_msg_kex_dh_gex_reply{} = Msg, {key_exchange_dh_gex_reply,client,ReNeg}, D) -> + {ok, NewKeys, Ssh1} = ssh_transport:handle_kex_dh_gex_reply(Msg, D#data.ssh_params), + ok = send_bytes(NewKeys, D), + {next_state, {new_keys,client,ReNeg}, D#data{ssh_params=Ssh1}}; -%%-------------------------------------------------------------------- --spec service_request(#ssh_msg_service_request{} | #ssh_msg_service_accept{}, - #state{}) -> gen_fsm_state_return(). -%%-------------------------------------------------------------------- -service_request(#ssh_msg_service_request{name = "ssh-userauth"} = Msg, - #state{ssh_params = #ssh{role = server, - session_id = SessionId} = Ssh0} = State) -> - {ok, {Reply, Ssh}} = ssh_auth:handle_userauth_request(Msg, SessionId, Ssh0), - send_msg(Reply, State), - {next_state, userauth, next_packet(State#state{ssh_params = Ssh})}; - -service_request(#ssh_msg_service_accept{name = "ssh-userauth"}, - #state{ssh_params = #ssh{role = client, - service = "ssh-userauth"} = Ssh0} = - State) -> + +%%% ######## {new_keys, client|server} #### + +%% First key exchange round: +handle_event(_, #ssh_msg_newkeys{} = Msg, {new_keys,Role,init}, D) -> + {ok, Ssh1} = ssh_transport:handle_new_keys(Msg, D#data.ssh_params), + Ssh = case Role of + client -> + {MsgReq, Ssh2} = ssh_auth:service_request_msg(Ssh1), + ok = send_bytes(MsgReq, D), + Ssh2; + server -> + Ssh1 + end, + {next_state, {service_request,Role}, D#data{ssh_params=Ssh}}; + +%% Subsequent key exchange rounds (renegotiation): +handle_event(_, #ssh_msg_newkeys{}, {new_keys,Role,renegotiate}, D) -> + {next_state, {connected,Role}, D}; + +%%% ######## {service_request, client|server} + +handle_event(_, Msg = #ssh_msg_service_request{name=ServiceName}, StateName = {service_request,server}, D) -> + case ServiceName of + "ssh-userauth" -> + Ssh0 = #ssh{session_id=SessionId} = D#data.ssh_params, + {ok, {Reply, Ssh}} = ssh_auth:handle_userauth_request(Msg, SessionId, Ssh0), + ok = send_bytes(Reply, D), + {next_state, {userauth,server}, D#data{ssh_params = Ssh}}; + + _ -> + disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + description = "Unknown service"}, + StateName, D) + end; + +handle_event(_, #ssh_msg_service_accept{name = "ssh-userauth"}, {service_request,client}, + #data{ssh_params = #ssh{service="ssh-userauth"} = Ssh0} = State) -> {Msg, Ssh} = ssh_auth:init_userauth_request_msg(Ssh0), - send_msg(Msg, State), - {next_state, userauth, next_packet(State#state{auth_user = Ssh#ssh.user, ssh_params = Ssh})}. + ok = send_bytes(Msg, State), + {next_state, {userauth,client}, State#data{auth_user = Ssh#ssh.user, ssh_params = Ssh}}; -%%-------------------------------------------------------------------- --spec userauth(#ssh_msg_userauth_request{} | #ssh_msg_userauth_info_request{} | - #ssh_msg_userauth_info_response{} | #ssh_msg_userauth_success{} | - #ssh_msg_userauth_failure{} | #ssh_msg_userauth_banner{}, - #state{}) -> gen_fsm_state_return(). -%%-------------------------------------------------------------------- -userauth(#ssh_msg_userauth_request{service = "ssh-connection", - method = "none"} = Msg, - #state{ssh_params = #ssh{session_id = SessionId, role = server, - service = "ssh-connection"} = Ssh0 - } = State) -> - {not_authorized, {_User, _Reason}, {Reply, Ssh}} = - ssh_auth:handle_userauth_request(Msg, SessionId, Ssh0), - send_msg(Reply, State), - {next_state, userauth, next_packet(State#state{ssh_params = Ssh})}; - -userauth(#ssh_msg_userauth_request{service = "ssh-connection", - method = Method} = Msg, - #state{ssh_params = #ssh{session_id = SessionId, role = server, - service = "ssh-connection", - peer = {_, Address}} = Ssh0, - opts = Opts, starter = Pid} = State) -> - case lists:member(Method, Ssh0#ssh.userauth_methods) of - true -> - case ssh_auth:handle_userauth_request(Msg, SessionId, Ssh0) of - {authorized, User, {Reply, Ssh}} -> - send_msg(Reply, State), - Pid ! ssh_connected, - connected_fun(User, Address, Method, Opts), - {next_state, connected, - next_packet(State#state{auth_user = User, ssh_params = Ssh#ssh{authenticated = true}})}; - {not_authorized, {User, Reason}, {Reply, Ssh}} when Method == "keyboard-interactive" -> - retry_fun(User, Address, Reason, Opts), - send_msg(Reply, State), - {next_state, userauth_keyboard_interactive, next_packet(State#state{ssh_params = Ssh})}; - {not_authorized, {User, Reason}, {Reply, Ssh}} -> - retry_fun(User, Address, Reason, Opts), - send_msg(Reply, State), - {next_state, userauth, next_packet(State#state{ssh_params = Ssh})} + +%%% ######## {userauth, client|server} #### + +%%---- userauth request to server +handle_event(_, + Msg = #ssh_msg_userauth_request{service = ServiceName, method = Method}, + StateName = {userauth,server}, + D = #data{ssh_params=Ssh0}) -> + + case {ServiceName, Ssh0#ssh.service, Method} of + {"ssh-connection", "ssh-connection", "none"} -> + %% Probably the very first userauth_request but we deny unauthorized login + {not_authorized, _, {Reply,Ssh}} = + ssh_auth:handle_userauth_request(Msg, Ssh0#ssh.session_id, Ssh0), + ok = send_bytes(Reply, D), + {keep_state, D#data{ssh_params = Ssh}}; + + {"ssh-connection", "ssh-connection", Method} -> + %% Userauth request with a method like "password" or so + case lists:member(Method, Ssh0#ssh.userauth_methods) of + true -> + %% Yepp! we support this method + case ssh_auth:handle_userauth_request(Msg, Ssh0#ssh.session_id, Ssh0) of + {authorized, User, {Reply, Ssh}} -> + ok = send_bytes(Reply, D), + D#data.starter ! ssh_connected, + connected_fun(User, Method, D), + {next_state, {connected,server}, + D#data{auth_user = User, + ssh_params = Ssh#ssh{authenticated = true}}}; + {not_authorized, {User, Reason}, {Reply, Ssh}} when Method == "keyboard-interactive" -> + retry_fun(User, Reason, D), + ok = send_bytes(Reply, D), + {next_state, {userauth_keyboard_interactive,server}, D#data{ssh_params = Ssh}}; + {not_authorized, {User, Reason}, {Reply, Ssh}} -> + retry_fun(User, Reason, D), + ok = send_bytes(Reply, D), + {keep_state, D#data{ssh_params = Ssh}} + end; + false -> + %% No we do not support this method (=/= none) + %% At least one non-erlang client does like this. Retry as the next event + {keep_state_and_data, + [{next_event, internal, Msg#ssh_msg_userauth_request{method="none"}}] + } end; - false -> - userauth(Msg#ssh_msg_userauth_request{method="none"}, State) + + %% {"ssh-connection", Expected, Method} when Expected =/= ServiceName -> Do what? + %% {ServiceName, Expected, Method} when Expected =/= ServiceName -> Do what? + + {ServiceName, _, _} when ServiceName =/= "ssh-connection" -> + disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + description = "Unknown service"}, + StateName, D) end; -userauth(#ssh_msg_userauth_success{}, #state{ssh_params = #ssh{role = client} = Ssh, - starter = Pid} = State) -> - Pid ! ssh_connected, - {next_state, connected, next_packet(State#state{ssh_params = - Ssh#ssh{authenticated = true}})}; -userauth(#ssh_msg_userauth_failure{}, - #state{ssh_params = #ssh{role = client, - userauth_methods = []}} - = State) -> - Msg = #ssh_msg_disconnect{code = - ?SSH_DISCONNECT_NO_MORE_AUTH_METHODS_AVAILABLE, +%%---- userauth success to client +handle_event(_, #ssh_msg_userauth_success{}, {userauth,client}, D=#data{ssh_params = Ssh}) -> + D#data.starter ! ssh_connected, + {next_state, {connected,client}, D#data{ssh_params=Ssh#ssh{authenticated = true}}}; + + +%%---- userauth failure response to client +handle_event(_, #ssh_msg_userauth_failure{}, {userauth,client}=StateName, + D = #data{ssh_params = #ssh{userauth_methods = []}}) -> + Msg = #ssh_msg_disconnect{code = ?SSH_DISCONNECT_NO_MORE_AUTH_METHODS_AVAILABLE, description = "Unable to connect using the available" - " authentication methods", - language = "en"}, - handle_disconnect(Msg, State); - -%% Server tells us which authentication methods that are allowed -userauth(#ssh_msg_userauth_failure{authentications = Methodes}, - #state{ssh_params = #ssh{role = client, - userauth_methods = none} = Ssh0} = State) -> - AuthMethods = string:tokens(Methodes, ","), - Ssh1 = Ssh0#ssh{userauth_methods = AuthMethods}, + " authentication methods"}, + disconnect(Msg, StateName, D); + +handle_event(_, #ssh_msg_userauth_failure{authentications = Methods}, StateName={userauth,client}, + D = #data{ssh_params = Ssh0}) -> + %% The prefered authentication method failed try next method + Ssh1 = case Ssh0#ssh.userauth_methods of + none -> + %% Server tells us which authentication methods that are allowed + Ssh0#ssh{userauth_methods = string:tokens(Methods, ",")}; + _ -> + %% We already know... + Ssh0 + end, case ssh_auth:userauth_request_msg(Ssh1) of {disconnect, DisconnectMsg, {Msg, Ssh}} -> - send_msg(Msg, State), - handle_disconnect(DisconnectMsg, State#state{ssh_params = Ssh}); + send_bytes(Msg, D), + disconnect(DisconnectMsg, StateName, D#data{ssh_params = Ssh}); {"keyboard-interactive", {Msg, Ssh}} -> - send_msg(Msg, State), - {next_state, userauth_keyboard_interactive, next_packet(State#state{ssh_params = Ssh})}; + send_bytes(Msg, D), + {next_state, {userauth_keyboard_interactive,client}, D#data{ssh_params = Ssh}}; {_Method, {Msg, Ssh}} -> - send_msg(Msg, State), - {next_state, userauth, next_packet(State#state{ssh_params = Ssh})} + send_bytes(Msg, D), + {keep_state, D#data{ssh_params = Ssh}} end; -%% The prefered authentication method failed try next method -userauth(#ssh_msg_userauth_failure{}, - #state{ssh_params = #ssh{role = client} = Ssh0} = State) -> - case ssh_auth:userauth_request_msg(Ssh0) of - {disconnect, DisconnectMsg,{Msg, Ssh}} -> - send_msg(Msg, State), - handle_disconnect(DisconnectMsg, State#state{ssh_params = Ssh}); - {"keyboard-interactive", {Msg, Ssh}} -> - send_msg(Msg, State), - {next_state, userauth_keyboard_interactive, next_packet(State#state{ssh_params = Ssh})}; - {_Method, {Msg, Ssh}} -> - send_msg(Msg, State), - {next_state, userauth, next_packet(State#state{ssh_params = Ssh})} - end; +%%---- banner to client +handle_event(_, #ssh_msg_userauth_banner{message = Msg}, {userauth,client}, D) -> + case D#data.ssh_params#ssh.userauth_quiet_mode of + false -> io:format("~s", [Msg]); + true -> ok + end, + keep_state_and_data; -userauth(#ssh_msg_userauth_banner{}, - #state{ssh_params = #ssh{userauth_quiet_mode = true, - role = client}} = State) -> - {next_state, userauth, next_packet(State)}; -userauth(#ssh_msg_userauth_banner{message = Msg}, - #state{ssh_params = - #ssh{userauth_quiet_mode = false, role = client}} = State) -> - io:format("~s", [Msg]), - {next_state, userauth, next_packet(State)}. - - - -userauth_keyboard_interactive(#ssh_msg_userauth_info_request{} = Msg, - #state{ssh_params = #ssh{role = client, - io_cb = IoCb} = Ssh0} = State) -> - {ok, {Reply, Ssh}} = ssh_auth:handle_userauth_info_request(Msg, IoCb, Ssh0), - send_msg(Reply, State), - {next_state, userauth_keyboard_interactive_info_response, next_packet(State#state{ssh_params = Ssh})}; - -userauth_keyboard_interactive(#ssh_msg_userauth_info_response{} = Msg, - #state{ssh_params = #ssh{role = server, - peer = {_, Address}} = Ssh0, - opts = Opts, starter = Pid} = State) -> - case ssh_auth:handle_userauth_info_response(Msg, Ssh0) of + +%%% ######## {userauth_keyboard_interactive, client|server} + +handle_event(_, #ssh_msg_userauth_info_request{} = Msg, {userauth_keyboard_interactive, client}, + #data{ssh_params = Ssh0} = D) -> + {ok, {Reply, Ssh}} = ssh_auth:handle_userauth_info_request(Msg, Ssh0#ssh.io_cb, Ssh0), + send_bytes(Reply, D), + {next_state, {userauth_keyboard_interactive_info_response,client}, D#data{ssh_params = Ssh}}; + +handle_event(_, #ssh_msg_userauth_info_response{} = Msg, {userauth_keyboard_interactive, server}, D) -> + case ssh_auth:handle_userauth_info_response(Msg, D#data.ssh_params) of {authorized, User, {Reply, Ssh}} -> - send_msg(Reply, State), - Pid ! ssh_connected, - connected_fun(User, Address, "keyboard-interactive", Opts), - {next_state, connected, - next_packet(State#state{auth_user = User, ssh_params = Ssh#ssh{authenticated = true}})}; + send_bytes(Reply, D), + D#data.starter ! ssh_connected, + connected_fun(User, "keyboard-interactive", D), + {next_state, {connected,server}, D#data{auth_user = User, + ssh_params = Ssh#ssh{authenticated = true}}}; {not_authorized, {User, Reason}, {Reply, Ssh}} -> - retry_fun(User, Address, Reason, Opts), - send_msg(Reply, State), - {next_state, userauth, next_packet(State#state{ssh_params = Ssh})} + retry_fun(User, Reason, D), + send_bytes(Reply, D), + {next_state, {userauth,server}, D#data{ssh_params = Ssh}} end; -userauth_keyboard_interactive(Msg = #ssh_msg_userauth_failure{}, - #state{ssh_params = Ssh0 = - #ssh{role = client, - userauth_preference = Prefs0}} - = State) -> - Prefs = [{Method,M,F,A} || {Method,M,F,A} <- Prefs0, + +handle_event(_, Msg = #ssh_msg_userauth_failure{}, {userauth_keyboard_interactive, client}, + #data{ssh_params = Ssh0} = D0) -> + Prefs = [{Method,M,F,A} || {Method,M,F,A} <- Ssh0#ssh.userauth_preference, Method =/= "keyboard-interactive"], - userauth(Msg, State#state{ssh_params = Ssh0#ssh{userauth_preference=Prefs}}). + D = D0#data{ssh_params = Ssh0#ssh{userauth_preference=Prefs}}, + {next_state, {userauth,client}, D, [{next_event, internal, Msg}]}; +handle_event(_, Msg=#ssh_msg_userauth_failure{}, {userauth_keyboard_interactive_info_response, client}, D) -> + {next_state, {userauth,client}, D, [{next_event, internal, Msg}]}; +handle_event(_, Msg=#ssh_msg_userauth_success{}, {userauth_keyboard_interactive_info_response, client}, D) -> + {next_state, {userauth,client}, D, [{next_event, internal, Msg}]}; -userauth_keyboard_interactive_info_response(Msg=#ssh_msg_userauth_failure{}, - #state{ssh_params = #ssh{role = client}} = State) -> - userauth(Msg, State); -userauth_keyboard_interactive_info_response(Msg=#ssh_msg_userauth_success{}, - #state{ssh_params = #ssh{role = client}} = State) -> - userauth(Msg, State); -userauth_keyboard_interactive_info_response(Msg=#ssh_msg_userauth_info_request{}, - #state{ssh_params = #ssh{role = client}} = State) -> - userauth_keyboard_interactive(Msg, State). +handle_event(_, Msg=#ssh_msg_userauth_info_request{}, {userauth_keyboard_interactive_info_response, client}, D) -> + {next_state, {userauth_keyboard_interactive,client}, D, [{next_event, internal, Msg}]}; -%%-------------------------------------------------------------------- --spec connected({#ssh_msg_kexinit{}, binary()}, %%| %% #ssh_msg_kexdh_init{}, - #state{}) -> gen_fsm_state_return(). -%%-------------------------------------------------------------------- -connected({#ssh_msg_kexinit{}, _Payload} = Event, #state{ssh_params = Ssh0} = State0) -> - {KeyInitMsg, SshPacket, Ssh} = ssh_transport:key_exchange_init_msg(Ssh0), - State = State0#state{ssh_params = Ssh, - key_exchange_init_msg = KeyInitMsg, - renegotiate = true}, - send_msg(SshPacket, State), - kexinit(Event, State). -%%-------------------------------------------------------------------- --spec handle_event(#ssh_msg_disconnect{} | #ssh_msg_ignore{} | #ssh_msg_debug{} | - #ssh_msg_unimplemented{} | {adjust_window, integer(), integer()} | - {reply_request, success | failure, integer()} | renegotiate | - data_size | {request, pid(), integer(), integer(), iolist()} | - {request, integer(), integer(), iolist()}, state_name(), - #state{}) -> gen_fsm_state_return(). +%%% ######## {connected, client|server} #### -%%-------------------------------------------------------------------- -handle_event(#ssh_msg_disconnect{description = Desc} = DisconnectMsg, _StateName, #state{} = State) -> - handle_disconnect(peer, DisconnectMsg, State), - {stop, {shutdown, Desc}, State}; - -handle_event(#ssh_msg_ignore{}, StateName, State) -> - {next_state, StateName, next_packet(State)}; - -handle_event(#ssh_msg_debug{always_display = Display, message = DbgMsg, language=Lang}, - StateName, #state{opts = Opts} = State) -> - F = proplists:get_value(ssh_msg_debug_fun, Opts, - fun(_ConnRef, _AlwaysDisplay, _Msg, _Language) -> ok end - ), - catch F(self(), Display, DbgMsg, Lang), - {next_state, StateName, next_packet(State)}; - -handle_event(#ssh_msg_unimplemented{}, StateName, State) -> - {next_state, StateName, next_packet(State)}; - -handle_event(renegotiate, connected, #state{ssh_params = Ssh0} - = State) -> - {KeyInitMsg, SshPacket, Ssh} = ssh_transport:key_exchange_init_msg(Ssh0), - send_msg(SshPacket, State), - timer:apply_after(?REKEY_TIMOUT, gen_fsm, send_all_state_event, [self(), renegotiate]), - {next_state, kexinit, - next_packet(State#state{ssh_params = Ssh, - key_exchange_init_msg = KeyInitMsg, - renegotiate = true})}; - -handle_event(renegotiate, StateName, State) -> +handle_event(_, {#ssh_msg_kexinit{},_} = Event, {connected,Role}, D0) -> + {KeyInitMsg, SshPacket, Ssh} = ssh_transport:key_exchange_init_msg(D0#data.ssh_params), + D = D0#data{ssh_params = Ssh, + key_exchange_init_msg = KeyInitMsg}, + send_bytes(SshPacket, D), + {next_state, {kexinit,Role,renegotiate}, D, [{next_event, internal, Event}]}; + +handle_event(_, #ssh_msg_disconnect{description=Desc} = Msg, StateName, D0) -> + {disconnect, _, {{replies,Replies}, _}} = + ssh_connection:handle_msg(Msg, D0#data.connection_state, role(StateName)), + {Actions,D} = send_replies(Replies, D0), + disconnect_fun(Desc, D), + {stop_and_reply, {shutdown,Desc}, Actions, D}; + +handle_event(_, #ssh_msg_ignore{}, _, _) -> + keep_state_and_data; + +handle_event(_, #ssh_msg_unimplemented{}, _, _) -> + keep_state_and_data; + +handle_event(_, #ssh_msg_debug{} = Msg, _, D) -> + debug_fun(Msg, D), + keep_state_and_data; + +handle_event(internal, Msg=#ssh_msg_global_request{}, StateName, D) -> + handle_connection_msg(Msg, StateName, D); + +handle_event(internal, Msg=#ssh_msg_request_success{}, StateName, D) -> + handle_connection_msg(Msg, StateName, D); + +handle_event(internal, Msg=#ssh_msg_request_failure{}, StateName, D) -> + handle_connection_msg(Msg, StateName, D); + +handle_event(internal, Msg=#ssh_msg_channel_open{}, StateName, D) -> + handle_connection_msg(Msg, StateName, D); + +handle_event(internal, Msg=#ssh_msg_channel_open_confirmation{}, StateName, D) -> + handle_connection_msg(Msg, StateName, D); + +handle_event(internal, Msg=#ssh_msg_channel_open_failure{}, StateName, D) -> + handle_connection_msg(Msg, StateName, D); + +handle_event(internal, Msg=#ssh_msg_channel_window_adjust{}, StateName, D) -> + handle_connection_msg(Msg, StateName, D); + +handle_event(internal, Msg=#ssh_msg_channel_data{}, StateName, D) -> + handle_connection_msg(Msg, StateName, D); + +handle_event(internal, Msg=#ssh_msg_channel_extended_data{}, StateName, D) -> + handle_connection_msg(Msg, StateName, D); + +handle_event(internal, Msg=#ssh_msg_channel_eof{}, StateName, D) -> + handle_connection_msg(Msg, StateName, D); + +handle_event(internal, Msg=#ssh_msg_channel_close{}, StateName, D) -> + handle_connection_msg(Msg, StateName, D); + +handle_event(internal, Msg=#ssh_msg_channel_request{}, StateName, D) -> + handle_connection_msg(Msg, StateName, D); + +handle_event(internal, Msg=#ssh_msg_channel_success{}, StateName, D) -> + handle_connection_msg(Msg, StateName, D); + +handle_event(internal, Msg=#ssh_msg_channel_failure{}, StateName, D) -> + handle_connection_msg(Msg, StateName, D); + + +handle_event(cast, renegotiate, {connected,Role}, D) -> + {KeyInitMsg, SshPacket, Ssh} = ssh_transport:key_exchange_init_msg(D#data.ssh_params), + send_bytes(SshPacket, D), + timer:apply_after(?REKEY_TIMOUT, gen_statem, cast, [self(), renegotiate]), + {next_state, {kexinit,Role,renegotiate}, D#data{ssh_params = Ssh, + key_exchange_init_msg = KeyInitMsg}}; + +handle_event(cast, renegotiate, _, _) -> %% Already in key-exchange so safe to ignore - {next_state, StateName, State}; + timer:apply_after(?REKEY_TIMOUT, gen_statem, cast, [self(), renegotiate]), % FIXME: not here in original + keep_state_and_data; + %% Rekey due to sent data limit reached? -handle_event(data_size, connected, #state{ssh_params = Ssh0} = State) -> - {ok, [{send_oct,Sent0}]} = inet:getstat(State#state.socket, [send_oct]), - Sent = Sent0 - State#state.last_size_rekey, - MaxSent = proplists:get_value(rekey_limit, State#state.opts, 1024000000), - timer:apply_after(?REKEY_DATA_TIMOUT, gen_fsm, send_all_state_event, [self(), data_size]), +handle_event(cast, data_size, {connected,Role}, D) -> + {ok, [{send_oct,Sent0}]} = inet:getstat(D#data.socket, [send_oct]), + Sent = Sent0 - D#data.last_size_rekey, + MaxSent = proplists:get_value(rekey_limit, D#data.opts, 1024000000), + timer:apply_after(?REKEY_DATA_TIMOUT, gen_statem, cast, [self(), data_size]), case Sent >= MaxSent of true -> - {KeyInitMsg, SshPacket, Ssh} = ssh_transport:key_exchange_init_msg(Ssh0), - send_msg(SshPacket, State), - {next_state, kexinit, - next_packet(State#state{ssh_params = Ssh, - key_exchange_init_msg = KeyInitMsg, - renegotiate = true, - last_size_rekey = Sent0})}; + {KeyInitMsg, SshPacket, Ssh} = + ssh_transport:key_exchange_init_msg(D#data.ssh_params), + send_bytes(SshPacket, D), + {next_state, {kexinit,Role,renegotiate}, D#data{ssh_params = Ssh, + key_exchange_init_msg = KeyInitMsg, + last_size_rekey = Sent0}}; _ -> - {next_state, connected, next_packet(State)} + keep_state_and_data end; -handle_event(data_size, StateName, State) -> + +handle_event(cast, data_size, _, _) -> %% Already in key-exchange so safe to ignore - {next_state, StateName, State}; - -handle_event(Event, StateName, State) when StateName /= connected -> - Events = [{event, Event} | State#state.event_queue], - {next_state, StateName, State#state{event_queue = Events}}; - -handle_event({adjust_window, ChannelId, Bytes}, StateName, - #state{connection_state = - #connection{channel_cache = Cache}} = State0) -> - State = - case ssh_channel:cache_lookup(Cache, ChannelId) of - #channel{recv_window_size = WinSize, - recv_window_pending = Pending, - recv_packet_size = PktSize} = Channel - when (WinSize-Bytes) >= 2*PktSize -> - %% The peer can send at least two more *full* packet, no hurry. - ssh_channel:cache_update(Cache, - Channel#channel{recv_window_pending = Pending + Bytes}), - State0; - - #channel{recv_window_size = WinSize, - recv_window_pending = Pending, - remote_id = Id} = Channel -> - %% Now we have to update the window - we can't receive so many more pkts - ssh_channel:cache_update(Cache, - Channel#channel{recv_window_size = - WinSize + Bytes + Pending, - recv_window_pending = 0}), - Msg = ssh_connection:channel_adjust_window_msg(Id, Bytes + Pending), - send_replies([{connection_reply, Msg}], State0); + timer:apply_after(?REKEY_DATA_TIMOUT, gen_statem, cast, [self(), data_size]), % FIXME: not here in original + keep_state_and_data; + + + +handle_event(cast, _, StateName, _) when StateName /= {connected,server}, + StateName /= {connected,client} -> + {keep_state_and_data, [postpone]}; + + +handle_event(cast, {adjust_window,ChannelId,Bytes}, {connected,_}, D) -> + case ssh_channel:cache_lookup(cache(D), ChannelId) of + #channel{recv_window_size = WinSize, + recv_window_pending = Pending, + recv_packet_size = PktSize} = Channel + when (WinSize-Bytes) >= 2*PktSize -> + %% The peer can send at least two more *full* packet, no hurry. + ssh_channel:cache_update(cache(D), + Channel#channel{recv_window_pending = Pending + Bytes}), + keep_state_and_data; + + #channel{recv_window_size = WinSize, + recv_window_pending = Pending, + remote_id = Id} = Channel -> + %% Now we have to update the window - we can't receive so many more pkts + ssh_channel:cache_update(cache(D), + Channel#channel{recv_window_size = + WinSize + Bytes + Pending, + recv_window_pending = 0}), + Msg = ssh_connection:channel_adjust_window_msg(Id, Bytes + Pending), + {keep_state, send_msg(Msg,D)}; - undefined -> - State0 - end, - {next_state, StateName, next_packet(State)}; - -handle_event({reply_request, success, ChannelId}, StateName, - #state{connection_state = - #connection{channel_cache = Cache}} = State0) -> - State = case ssh_channel:cache_lookup(Cache, ChannelId) of - #channel{remote_id = RemoteId} -> - Msg = ssh_connection:channel_success_msg(RemoteId), - send_replies([{connection_reply, Msg}], State0); - undefined -> - State0 - end, - {next_state, StateName, State}; - -handle_event({request, ChannelPid, ChannelId, Type, Data}, StateName, State0) -> - {{replies, Replies}, State1} = handle_request(ChannelPid, ChannelId, - Type, Data, - false, none, State0), - State = send_replies(Replies, State1), - {next_state, StateName, next_packet(State)}; - -handle_event({request, ChannelId, Type, Data}, StateName, State0) -> - {{replies, Replies}, State1} = handle_request(ChannelId, Type, Data, - false, none, State0), - State = send_replies(Replies, State1), - {next_state, StateName, next_packet(State)}; - -handle_event({unknown, Data}, StateName, State) -> + undefined -> + keep_state_and_data + end; + +handle_event(cast, {reply_request,success,ChannelId}, {connected,_}, D) -> + case ssh_channel:cache_lookup(cache(D), ChannelId) of + #channel{remote_id = RemoteId} -> + Msg = ssh_connection:channel_success_msg(RemoteId), + {keep_state, send_msg(Msg,D)}; + + undefined -> + keep_state_and_data + end; + +handle_event(cast, {request,ChannelPid, ChannelId, Type, Data}, {connected,_}, D) -> + {keep_state, handle_request(ChannelPid, ChannelId, Type, Data, false, none, D)}; + +handle_event(cast, {request,ChannelId,Type,Data}, {connected,_}, D) -> + {keep_state, handle_request(ChannelId, Type, Data, false, none, D)}; + +handle_event(cast, {unknown,Data}, {connected,_}, D) -> Msg = #ssh_msg_unimplemented{sequence = Data}, - send_msg(Msg, State), - {next_state, StateName, next_packet(State)}. + {keep_state, send_msg(Msg,D)}; -%%-------------------------------------------------------------------- --spec handle_sync_event({request, pid(), channel_id(), integer(), binary(), timeout()} | - {request, channel_id(), integer(), binary(), timeout()} | - {global_request, pid(), integer(), boolean(), binary()} | {eof, integer()} | - {open, pid(), integer(), channel_id(), integer(), binary(), _} | - {send_window, channel_id()} | {recv_window, channel_id()} | - {connection_info, [client_version | server_version | peer | - sockname]} | {channel_info, channel_id(), [recv_window | - send_window]} | - {close, channel_id()} | stop, term(), state_name(), #state{}) - -> gen_fsm_sync_return(). -%%-------------------------------------------------------------------- -handle_sync_event(get_print_info, _From, StateName, State) -> +%%% Previously handle_sync_event began here +handle_event({call,From}, get_print_info, StateName, D) -> Reply = try - {inet:sockname(State#state.socket), - inet:peername(State#state.socket) + {inet:sockname(D#data.socket), + inet:peername(D#data.socket) } of - {{ok,Local}, {ok,Remote}} -> {{Local,Remote},io_lib:format("statename=~p",[StateName])}; - _ -> {{"-",0},"-"} + {{ok,Local}, {ok,Remote}} -> + {{Local,Remote},io_lib:format("statename=~p",[StateName])}; + _ -> + {{"-",0},"-"} catch - _:_ -> {{"?",0},"?"} + _:_ -> + {{"?",0},"?"} end, - {reply, Reply, StateName, State}; + {keep_state_and_data, [{reply,From,Reply}]}; -handle_sync_event({connection_info, Options}, _From, StateName, State) -> - Info = ssh_info(Options, State, []), - {reply, Info, StateName, State}; +handle_event({call,From}, {connection_info, Options}, _, D) -> + Info = ssh_info(Options, D, []), + {keep_state_and_data, [{reply,From,Info}]}; -handle_sync_event({channel_info, ChannelId, Options}, _From, StateName, - #state{connection_state = #connection{channel_cache = Cache}} = State) -> - case ssh_channel:cache_lookup(Cache, ChannelId) of - #channel{} = Channel -> +handle_event({call,From}, {channel_info,ChannelId,Options}, _, D) -> + case ssh_channel:cache_lookup(cache(D), ChannelId) of + #channel{} = Channel -> Info = ssh_channel_info(Options, Channel, []), - {reply, Info, StateName, State}; + {keep_state_and_data, [{reply,From,Info}]}; undefined -> - {reply, [], StateName, State} + {keep_state_and_data, [{reply,From,[]}]} end; -handle_sync_event({info, ChannelPid}, _From, StateName, - #state{connection_state = - #connection{channel_cache = Cache}} = State) -> + +handle_event({call,From}, {info, all}, _, D) -> + Result = ssh_channel:cache_foldl(fun(Channel, Acc) -> + [Channel | Acc] + end, + [], cache(D)), + {keep_state_and_data, [{reply, From, {ok,Result}}]}; + +handle_event({call,From}, {info, ChannelPid}, _, D) -> Result = ssh_channel:cache_foldl( - fun(Channel, Acc) when ChannelPid == all; - Channel#channel.user == ChannelPid -> + fun(Channel, Acc) when Channel#channel.user == ChannelPid -> [Channel | Acc]; (_, Acc) -> Acc - end, [], Cache), - {reply, {ok, Result}, StateName, State}; + end, [], cache(D)), + {keep_state_and_data, [{reply, From, {ok,Result}}]}; -handle_sync_event(stop, _, _StateName, #state{connection_state = Connection0, - role = Role} = State0) -> +handle_event({call,From}, stop, StateName, D0) -> {disconnect, _Reason, {{replies, Replies}, Connection}} = ssh_connection:handle_msg(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, - description = "User closed down connection", - language = "en"}, Connection0, Role), - State = send_replies(Replies, State0), - {stop, normal, ok, State#state{connection_state = Connection}}; - - -handle_sync_event(Event, From, StateName, State) when StateName /= connected -> - Events = [{sync, Event, From} | State#state.event_queue], - {next_state, StateName, State#state{event_queue = Events}}; - -handle_sync_event({request, ChannelPid, ChannelId, Type, Data, Timeout}, From, StateName, State0) -> - {{replies, Replies}, State1} = handle_request(ChannelPid, - ChannelId, Type, Data, - true, From, State0), - %% Note reply to channel will happen later when - %% reply is recived from peer on the socket - State = send_replies(Replies, State1), - start_timeout(ChannelId, From, Timeout), - handle_idle_timeout(State), - {next_state, StateName, next_packet(State)}; - -handle_sync_event({request, ChannelId, Type, Data, Timeout}, From, StateName, State0) -> - {{replies, Replies}, State1} = handle_request(ChannelId, Type, Data, - true, From, State0), - %% Note reply to channel will happen later when - %% reply is recived from peer on the socket - State = send_replies(Replies, State1), - start_timeout(ChannelId, From, Timeout), - handle_idle_timeout(State), - {next_state, StateName, next_packet(State)}; - -handle_sync_event({global_request, Pid, _, _, _} = Request, From, StateName, - #state{connection_state = - #connection{channel_cache = Cache}} = State0) -> - State1 = handle_global_request(Request, State0), - Channel = ssh_channel:cache_find(Pid, Cache), - State = add_request(true, Channel#channel.local_id, From, State1), - {next_state, StateName, next_packet(State)}; - -handle_sync_event({data, ChannelId, Type, Data, Timeout}, From, StateName, - #state{connection_state = #connection{channel_cache = _Cache} - = Connection0} = State0) -> - - case ssh_connection:channel_data(ChannelId, Type, Data, Connection0, From) of - {{replies, Replies}, Connection} -> - State = send_replies(Replies, State0#state{connection_state = Connection}), - start_timeout(ChannelId, From, Timeout), - {next_state, StateName, next_packet(State)}; - {noreply, Connection} -> - start_timeout(ChannelId, From, Timeout), - {next_state, StateName, next_packet(State0#state{connection_state = Connection})} - end; - -handle_sync_event({eof, ChannelId}, _From, StateName, - #state{connection_state = - #connection{channel_cache = Cache}} = State0) -> - case ssh_channel:cache_lookup(Cache, ChannelId) of + description = "User closed down connection"}, + D0#data.connection_state, + role(StateName)), + {Repls,D} = send_replies(Replies, D0), + {stop_and_reply, normal, [{reply,From,ok}|Repls], D#data{connection_state=Connection}}; + +handle_event({call,_}, _, StateName, _) when StateName /= {connected,server}, + StateName /= {connected,client} -> + {keep_state_and_data, [postpone]}; + +handle_event({call,From}, {request, ChannelPid, ChannelId, Type, Data, Timeout}, {connected,_}, D0) -> + D = handle_request(ChannelPid, ChannelId, Type, Data, true, From, D0), + %% Note reply to channel will happen later when reply is recived from peer on the socket + start_channel_request_timer(ChannelId, From, Timeout), + {keep_state, cache_request_idle_timer_check(D)}; + +handle_event({call,From}, {request, ChannelId, Type, Data, Timeout}, {connected,_}, D0) -> + D = handle_request(ChannelId, Type, Data, true, From, D0), + %% Note reply to channel will happen later when reply is recived from peer on the socket + start_channel_request_timer(ChannelId, From, Timeout), + {keep_state, cache_request_idle_timer_check(D)}; + +handle_event({call,From}, {data, ChannelId, Type, Data, Timeout}, {connected,_}, D0) -> + {{replies, Replies}, Connection} = + ssh_connection:channel_data(ChannelId, Type, Data, D0#data.connection_state, From), + {Repls,D} = send_replies(Replies, D0#data{connection_state = Connection}), + start_channel_request_timer(ChannelId, From, Timeout), % FIXME: No message exchange so why? + {keep_state, D, Repls}; + +handle_event({call,From}, {eof, ChannelId}, {connected,_}, D0) -> + case ssh_channel:cache_lookup(cache(D0), ChannelId) of #channel{remote_id = Id, sent_close = false} -> - State = send_replies([{connection_reply, - ssh_connection:channel_eof_msg(Id)}], State0), - {reply, ok, StateName, next_packet(State)}; + D = send_msg(ssh_connection:channel_eof_msg(Id), D0), + {keep_state, D, [{reply,From,ok}]}; _ -> - {reply, {error,closed}, StateName, State0} + {keep_state, D0, [{reply,From,{error,closed}}]} end; -handle_sync_event({open, ChannelPid, Type, InitialWindowSize, MaxPacketSize, Data, Timeout}, - From, StateName, #state{connection_state = - #connection{channel_cache = Cache}} = State0) -> +handle_event({call,From}, + {open, ChannelPid, Type, InitialWindowSize, MaxPacketSize, Data, Timeout}, + {connected,_}, + D0) -> erlang:monitor(process, ChannelPid), - {ChannelId, State1} = new_channel_id(State0), - Msg = ssh_connection:channel_open_msg(Type, ChannelId, - InitialWindowSize, - MaxPacketSize, Data), - State2 = send_replies([{connection_reply, Msg}], State1), - Channel = #channel{type = Type, - sys = "none", - user = ChannelPid, - local_id = ChannelId, - recv_window_size = InitialWindowSize, - recv_packet_size = MaxPacketSize, - send_buf = queue:new() - }, - ssh_channel:cache_update(Cache, Channel), - State = add_request(true, ChannelId, From, State2), - start_timeout(ChannelId, From, Timeout), - {next_state, StateName, next_packet(remove_timer_ref(State))}; - -handle_sync_event({send_window, ChannelId}, _From, StateName, - #state{connection_state = - #connection{channel_cache = Cache}} = State) -> - Reply = case ssh_channel:cache_lookup(Cache, ChannelId) of + {ChannelId, D1} = new_channel_id(D0), + D2 = send_msg(ssh_connection:channel_open_msg(Type, ChannelId, + InitialWindowSize, + MaxPacketSize, Data), + D1), + ssh_channel:cache_update(cache(D2), + #channel{type = Type, + sys = "none", + user = ChannelPid, + local_id = ChannelId, + recv_window_size = InitialWindowSize, + recv_packet_size = MaxPacketSize, + send_buf = queue:new() + }), + D = add_request(true, ChannelId, From, D2), + start_channel_request_timer(ChannelId, From, Timeout), + {keep_state, cache_cancel_idle_timer(D)}; + +handle_event({call,From}, {send_window, ChannelId}, {connected,_}, D) -> + Reply = case ssh_channel:cache_lookup(cache(D), ChannelId) of #channel{send_window_size = WinSize, send_packet_size = Packsize} -> {ok, {WinSize, Packsize}}; undefined -> {error, einval} end, - {reply, Reply, StateName, next_packet(State)}; - -handle_sync_event({recv_window, ChannelId}, _From, StateName, - #state{connection_state = #connection{channel_cache = Cache}} - = State) -> + {keep_state_and_data, [{reply,From,Reply}]}; - Reply = case ssh_channel:cache_lookup(Cache, ChannelId) of +handle_event({call,From}, {recv_window, ChannelId}, {connected,_}, D) -> + Reply = case ssh_channel:cache_lookup(cache(D), ChannelId) of #channel{recv_window_size = WinSize, recv_packet_size = Packsize} -> {ok, {WinSize, Packsize}}; undefined -> {error, einval} end, - {reply, Reply, StateName, next_packet(State)}; - -handle_sync_event({close, ChannelId}, _, StateName, - #state{connection_state = - #connection{channel_cache = Cache}} = State0) -> - State = - case ssh_channel:cache_lookup(Cache, ChannelId) of - #channel{remote_id = Id} = Channel -> - State1 = send_replies([{connection_reply, - ssh_connection:channel_close_msg(Id)}], State0), - ssh_channel:cache_update(Cache, Channel#channel{sent_close = true}), - handle_idle_timeout(State1), - State1; - undefined -> - State0 - end, - {reply, ok, StateName, next_packet(State)}. + {keep_state_and_data, [{reply,From,Reply}]}; + +handle_event({call,From}, {close, ChannelId}, {connected,_}, D0) -> + case ssh_channel:cache_lookup(cache(D0), ChannelId) of + #channel{remote_id = Id} = Channel -> + D1 = send_msg(ssh_connection:channel_close_msg(Id), D0), + ssh_channel:cache_update(cache(D1), Channel#channel{sent_close = true}), + {keep_state, cache_request_idle_timer_check(D1), [{reply,From,ok}]}; + undefined -> + {keep_state_and_data, [{reply,From,ok}]} + end; -%%-------------------------------------------------------------------- --spec handle_info({atom(), port(), binary()} | {atom(), port()} | - term (), state_name(), #state{}) -> gen_fsm_state_return(). -%%-------------------------------------------------------------------- -handle_info({Protocol, Socket, "SSH-" ++ _ = Version}, hello, - #state{socket = Socket, - transport_protocol = Protocol} = State ) -> - event({version_exchange, Version}, hello, State); - -handle_info({Protocol, Socket, Info}, hello, - #state{socket = Socket, - transport_protocol = Protocol} = State) -> - event({info_line, Info}, hello, State); - -handle_info({Protocol, Socket, Data}, StateName, - #state{socket = Socket, - transport_protocol = Protocol, - ssh_params = Ssh0, - decoded_data_buffer = DecData0, - encoded_data_buffer = EncData0, - undecoded_packet_length = RemainingSshPacketLen0} = State0) -> - Encoded = <<EncData0/binary, Data/binary>>, - try ssh_transport:handle_packet_part(DecData0, Encoded, RemainingSshPacketLen0, Ssh0) +%%===== Reception of encrypted bytes, decryption and framing +handle_event(info, {Proto, Sock, Info}, {hello,_}, #data{socket = Sock, + transport_protocol = Proto}) -> + case Info of + "SSH-" ++ _ -> + {keep_state_and_data, [{next_event, internal, {version_exchange,Info}}]}; + _ -> + {keep_state_and_data, [{next_event, internal, {info_line,Info}}]} + end; + +handle_event(info, {Proto, Sock, NewData}, StateName, D0 = #data{socket = Sock, + transport_protocol = Proto}) -> + try ssh_transport:handle_packet_part( + D0#data.decrypted_data_buffer, + <<(D0#data.encrypted_data_buffer)/binary, NewData/binary>>, + D0#data.undecrypted_packet_length, + D0#data.ssh_params) of - {get_more, DecBytes, EncDataRest, RemainingSshPacketLen, Ssh1} -> - {next_state, StateName, - next_packet(State0#state{encoded_data_buffer = EncDataRest, - decoded_data_buffer = DecBytes, - undecoded_packet_length = RemainingSshPacketLen, - ssh_params = Ssh1})}; - {decoded, MsgBytes, EncDataRest, Ssh1} -> - generate_event(MsgBytes, StateName, - State0#state{ssh_params = Ssh1, - %% Important to be set for - %% next_packet -%%% FIXME: the following three seem to always be set in generate_event! - decoded_data_buffer = <<>>, - undecoded_packet_length = undefined, - encoded_data_buffer = EncDataRest}, - EncDataRest); + {packet_decrypted, DecryptedBytes, EncryptedDataRest, Ssh1} -> + D = D0#data{ssh_params = + Ssh1#ssh{recv_sequence = ssh_transport:next_seqnum(Ssh1#ssh.recv_sequence)}, + decrypted_data_buffer = <<>>, + undecrypted_packet_length = undefined, + encrypted_data_buffer = EncryptedDataRest}, + try + ssh_message:decode(set_kex_overload_prefix(DecryptedBytes,D)) + of + Msg = #ssh_msg_kexinit{} -> + {keep_state, D, [{next_event, internal, {Msg,DecryptedBytes}}, + {next_event, internal, prepare_next_packet} + ]}; + Msg -> + {keep_state, D, [{next_event, internal, Msg}, + {next_event, internal, prepare_next_packet} + ]} + catch + _C:_E -> + disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, + description = "Encountered unexpected input"}, + StateName, D) + end; + + {get_more, DecryptedBytes, EncryptedDataRest, RemainingSshPacketLen, Ssh1} -> + %% Here we know that there are not enough bytes in + %% EncryptedDataRest to use. We must wait for more. + inet:setopts(Sock, [{active, once}]), + {keep_state, D0#data{encrypted_data_buffer = EncryptedDataRest, + decrypted_data_buffer = DecryptedBytes, + undecrypted_packet_length = RemainingSshPacketLen, + ssh_params = Ssh1}}; + {bad_mac, Ssh1} -> - DisconnectMsg = - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "Bad mac", - language = ""}, - handle_disconnect(DisconnectMsg, State0#state{ssh_params=Ssh1}); + disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, + description = "Bad mac"}, + StateName, D0#data{ssh_params=Ssh1}); {error, {exceeds_max_size,PacketLen}} -> - DisconnectMsg = - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "Bad packet length " - ++ integer_to_list(PacketLen), - language = ""}, - handle_disconnect(DisconnectMsg, State0) + disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, + description = "Bad packet length " + ++ integer_to_list(PacketLen)}, + StateName, D0) catch - _:_ -> - DisconnectMsg = - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "Bad packet", - language = ""}, - handle_disconnect(DisconnectMsg, State0) + _C:_E -> + disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, + description = "Bad packet"}, + StateName, D0) end; - -handle_info({CloseTag, _Socket}, _StateName, - #state{transport_close_tag = CloseTag, - ssh_params = #ssh{role = _Role, opts = _Opts}} = State) -> - DisconnectMsg = - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, - description = "Connection closed", - language = "en"}, - handle_disconnect(DisconnectMsg, State); - -handle_info({timeout, {_, From} = Request}, Statename, - #state{connection_state = #connection{requests = Requests} = Connection} = State) -> + + +%%%==== +handle_event(internal, prepare_next_packet, _, D) -> + Enough = erlang:max(8, D#data.ssh_params#ssh.decrypt_block_size), + case size(D#data.encrypted_data_buffer) of + Sz when Sz >= Enough -> + self() ! {D#data.transport_protocol, D#data.socket, <<>>}; + _ -> + inet:setopts(D#data.socket, [{active, once}]) + end, + keep_state_and_data; + +handle_event(info, {CloseTag,Socket}, StateName, + D = #data{socket = Socket, + transport_close_tag = CloseTag}) -> + disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, + description = "Connection closed"}, + StateName, D); + +handle_event(info, {timeout, {_, From} = Request}, _, + #data{connection_state = #connection{requests = Requests} = C0} = D) -> case lists:member(Request, Requests) of true -> - gen_fsm:reply(From, {error, timeout}), - {next_state, Statename, - State#state{connection_state = - Connection#connection{requests = - lists:delete(Request, Requests)}}}; + %% A channel request is not answered in time. Answer {error,timeout} + %% to the caller + C = C0#connection{requests = lists:delete(Request, Requests)}, + {keep_state, D#data{connection_state=C}, [{reply,From,{error,timeout}}]}; false -> - {next_state, Statename, State} + %% The request is answered - just ignore the timeout + keep_state_and_data end; %%% Handle that ssh channels user process goes down -handle_info({'DOWN', _Ref, process, ChannelPid, _Reason}, Statename, State0) -> - {{replies, Replies}, State1} = handle_channel_down(ChannelPid, State0), - State = send_replies(Replies, State1), - {next_state, Statename, next_packet(State)}; +handle_event(info, {'DOWN', _Ref, process, ChannelPid, _Reason}, _, D0) -> + {{replies, Replies}, D1} = handle_channel_down(ChannelPid, D0), + {Repls, D} = send_replies(Replies, D1), + {keep_state, D, Repls}; %%% So that terminate will be run when supervisor is shutdown -handle_info({'EXIT', _Sup, Reason}, _StateName, State) -> - {stop, {shutdown, Reason}, State}; +handle_event(info, {'EXIT', _Sup, Reason}, _, _) -> + {stop, {shutdown, Reason}}; -handle_info({check_cache, _ , _}, - StateName, #state{connection_state = - #connection{channel_cache = Cache}} = State) -> - {next_state, StateName, check_cache(State, Cache)}; +handle_event(info, check_cache, _, D) -> + {keep_state, cache_check_set_idle_timer(D)}; -handle_info(UnexpectedMessage, StateName, #state{opts = Opts, - ssh_params = SshParams} = State) -> - case unexpected_fun(UnexpectedMessage, Opts, SshParams) of +handle_event(info, UnexpectedMessage, StateName, D = #data{ssh_params = Ssh}) -> + case unexpected_fun(UnexpectedMessage, D) of report -> Msg = lists:flatten( io_lib:format( "Unexpected message '~p' received in state '~p'\n" "Role: ~p\n" "Peer: ~p\n" - "Local Address: ~p\n", [UnexpectedMessage, StateName, - SshParams#ssh.role, SshParams#ssh.peer, - proplists:get_value(address, SshParams#ssh.opts)])), - error_logger:info_report(Msg); + "Local Address: ~p\n", [UnexpectedMessage, + StateName, + Ssh#ssh.role, + Ssh#ssh.peer, + proplists:get_value(address, Ssh#ssh.opts)])), + error_logger:info_report(Msg), + keep_state_and_data; skip -> - ok; + keep_state_and_data; Other -> Msg = lists:flatten( @@ -1103,200 +1269,181 @@ handle_info(UnexpectedMessage, StateName, #state{opts = Opts, "Message: ~p\n" "Role: ~p\n" "Peer: ~p\n" - "Local Address: ~p\n", [Other, UnexpectedMessage, - SshParams#ssh.role, - element(2,SshParams#ssh.peer), - proplists:get_value(address, SshParams#ssh.opts)] + "Local Address: ~p\n", [Other, + UnexpectedMessage, + Ssh#ssh.role, + element(2,Ssh#ssh.peer), + proplists:get_value(address, Ssh#ssh.opts)] )), + error_logger:error_report(Msg), + keep_state_and_data + end; + +handle_event(internal, {disconnect,Msg,_Reason}, StateName, D) -> + disconnect(Msg, StateName, D); + +handle_event(Type, Ev, StateName, D) -> + Descr = + case catch atom_to_list(element(1,Ev)) of + "ssh_msg_" ++_ when Type==internal -> + "Message in wrong state"; + _ -> + "Internal error" + end, + disconnect(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, + description = Descr}, + StateName, D). - error_logger:error_report(Msg) - end, - {next_state, StateName, State}. %%-------------------------------------------------------------------- --spec terminate(Reason::term(), state_name(), #state{}) -> _. -%%-------------------------------------------------------------------- -terminate(normal, _, #state{transport_cb = Transport, - connection_state = Connection, - socket = Socket}) -> - terminate_subsystem(Connection), - (catch Transport:close(Socket)), - ok; +-spec terminate(any(), + state_name(), + #data{} + ) -> finalize_termination_result() . + +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +terminate(normal, StateName, State) -> + finalize_termination(StateName, State); terminate({shutdown,{init,Reason}}, StateName, State) -> error_logger:info_report(io_lib:format("Erlang ssh in connection handler init: ~p~n",[Reason])), - terminate(normal, StateName, State); - -%% Terminated by supervisor -terminate(shutdown, StateName, #state{ssh_params = Ssh0} = State) -> - DisconnectMsg = - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, - description = "Application shutdown", - language = "en"}, - {SshPacket, Ssh} = ssh_transport:ssh_packet(DisconnectMsg, Ssh0), - send_msg(SshPacket, State), - terminate(normal, StateName, State#state{ssh_params = Ssh}); - -terminate({shutdown, #ssh_msg_disconnect{} = Msg}, StateName, - #state{ssh_params = Ssh0} = State) -> - {SshPacket, Ssh} = ssh_transport:ssh_packet(Msg, Ssh0), - send_msg(SshPacket, State), - terminate(normal, StateName, State#state{ssh_params = Ssh}); - -terminate({shutdown, _}, StateName, State) -> - terminate(normal, StateName, State); - -terminate(Reason, StateName, #state{ssh_params = Ssh0, starter = _Pid, - connection_state = Connection} = State) -> - terminate_subsystem(Connection), + finalize_termination(StateName, State); + +terminate(shutdown, StateName, State0) -> + %% Terminated by supervisor + State = send_msg(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, + description = "Application shutdown"}, + State0), +timer:sleep(400), %% FIXME!!! gen_tcp:shutdown instead + finalize_termination(StateName, State); + +%% terminate({shutdown,Msg}, StateName, State0) when is_record(Msg,ssh_msg_disconnect)-> +%% State = send_msg(Msg, State0), +%% timer:sleep(400), %% FIXME!!! gen_tcp:shutdown instead +%% finalize_termination(StateName, Msg, State); + +terminate({shutdown,_R}, StateName, State) -> + finalize_termination(StateName, State); + +terminate(Reason, StateName, State0) -> + %% Others, e.g undef, {badmatch,_} log_error(Reason), - DisconnectMsg = - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, - description = "Internal error", - language = "en"}, - {SshPacket, Ssh} = ssh_transport:ssh_packet(DisconnectMsg, Ssh0), - send_msg(SshPacket, State), - terminate(normal, StateName, State#state{ssh_params = Ssh}). - - -terminate_subsystem(#connection{system_supervisor = SysSup, - sub_system_supervisor = SubSysSup}) when is_pid(SubSysSup) -> - ssh_system_sup:stop_subsystem(SysSup, SubSysSup); -terminate_subsystem(_) -> - ok. - -format_status(normal, [_, State]) -> - [{data, [{"StateData", State}]}]; -format_status(terminate, [_, State]) -> - SshParams0 = (State#state.ssh_params), - SshParams = SshParams0#ssh{c_keyinit = "***", - s_keyinit = "***", - send_mac_key = "***", - send_mac_size = "***", - recv_mac_key = "***", - recv_mac_size = "***", - encrypt_keys = "***", - encrypt_ctx = "***", - decrypt_keys = "***", - decrypt_ctx = "***", - compress_ctx = "***", - decompress_ctx = "***", - shared_secret = "***", - exchanged_hash = "***", - session_id = "***", - keyex_key = "***", - keyex_info = "***", - available_host_keys = "***"}, - [{data, [{"StateData", State#state{decoded_data_buffer = "***", - encoded_data_buffer = "***", - key_exchange_init_msg = "***", - opts = "***", - recbuf = "***", - ssh_params = SshParams - }}]}]. + State = send_msg(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, + description = "Internal error"}, + State0), + finalize_termination(StateName, State). %%-------------------------------------------------------------------- --spec code_change(OldVsn::term(), state_name(), Oldstate::term(), Extra::term()) -> - {ok, state_name(), #state{}}. + +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +format_status(normal, [_, _StateName, D]) -> + [{data, [{"State", D}]}]; +format_status(terminate, [_, _StateName, D]) -> + DataPropList0 = fmt_stat_rec(record_info(fields, data), D, + [decrypted_data_buffer, + encrypted_data_buffer, + key_exchange_init_msg, + user_passwords, + opts, + inet_initial_recbuf_size]), + SshPropList = fmt_stat_rec(record_info(fields, ssh), D#data.ssh_params, + [c_keyinit, + s_keyinit, + send_mac_key, + send_mac_size, + recv_mac_key, + recv_mac_size, + encrypt_keys, + encrypt_ctx, + decrypt_keys, + decrypt_ctx, + compress_ctx, + decompress_ctx, + shared_secret, + exchanged_hash, + session_id, + keyex_key, + keyex_info, + available_host_keys]), + DataPropList = lists:keyreplace(ssh_params, 1, DataPropList0, + {ssh_params,SshPropList}), + [{data, [{"State", DataPropList}]}]. + + +fmt_stat_rec(FieldNames, Rec, Exclude) -> + Values = tl(tuple_to_list(Rec)), + [P || {K,_} = P <- lists:zip(FieldNames, Values), + not lists:member(K, Exclude)]. + %%-------------------------------------------------------------------- +-spec code_change(term() | {down,term()}, + state_name(), + #data{}, + term() + ) -> {gen_statem:callback_mode(), state_name(), #data{}}. + +%% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + code_change(_OldVsn, StateName, State, _Extra) -> - {ok, StateName, State}. + {handle_event_function, StateName, State}. + + +%%==================================================================== +%% Internal functions +%%==================================================================== %%-------------------------------------------------------------------- -%%% Internal functions -%%-------------------------------------------------------------------- -init_role(#state{role = client, opts = Opts} = State0) -> - Pid = proplists:get_value(user_pid, Opts), - TimerRef = get_idle_time(Opts), - timer:apply_after(?REKEY_TIMOUT, gen_fsm, send_all_state_event, [self(), renegotiate]), - timer:apply_after(?REKEY_DATA_TIMOUT, gen_fsm, send_all_state_event, - [self(), data_size]), - State0#state{starter = Pid, - idle_timer_ref = TimerRef}; -init_role(#state{role = server, opts = Opts, connection_state = Connection} = State) -> - Sups = proplists:get_value(supervisors, Opts), - Pid = proplists:get_value(user_pid, Opts), - SystemSup = proplists:get_value(system_sup, Sups), - SubSystemSup = proplists:get_value(subsystem_sup, Sups), +%% Starting + +start_the_connection_child(UserPid, Role, Socket, Options) -> + Sups = proplists:get_value(supervisors, Options), ConnectionSup = proplists:get_value(connection_sup, Sups), - Shell = proplists:get_value(shell, Opts), - Exec = proplists:get_value(exec, Opts), - CliSpec = proplists:get_value(ssh_cli, Opts, {ssh_cli, [Shell]}), - State#state{starter = Pid, connection_state = Connection#connection{ - cli_spec = CliSpec, - exec = Exec, - system_supervisor = SystemSup, - sub_system_supervisor = SubSystemSup, - connection_supervisor = ConnectionSup - }}. - -get_idle_time(SshOptions) -> - case proplists:get_value(idle_time, SshOptions) of - infinity -> - infinity; - _IdleTime -> %% We dont want to set the timeout on first connect - undefined - end. + Opts = [{supervisors, Sups}, {user_pid, UserPid} | proplists:get_value(ssh_opts, Options, [])], + {ok, Pid} = ssh_connection_sup:start_child(ConnectionSup, [Role, Socket, Opts]), + ok = socket_control(Socket, Pid, Options), + Pid. -init_ssh(client = Role, Vsn, Version, Options, Socket) -> - IOCb = case proplists:get_value(user_interaction, Options, true) of - true -> - ssh_io; - false -> - ssh_no_io - end, +%%-------------------------------------------------------------------- +%% Stopping +-type finalize_termination_result() :: ok . + +finalize_termination(_StateName, #data{transport_cb = Transport, + connection_state = Connection, + socket = Socket}) -> + case Connection of + #connection{system_supervisor = SysSup, + sub_system_supervisor = SubSysSup} when is_pid(SubSysSup) -> + ssh_system_sup:stop_subsystem(SysSup, SubSysSup); + _ -> + do_nothing + end, + (catch Transport:close(Socket)), + ok. - AuthMethods = proplists:get_value(auth_methods, Options, - ?SUPPORTED_AUTH_METHODS), - {ok, PeerAddr} = inet:peername(Socket), - - PeerName = proplists:get_value(host, Options), - KeyCb = proplists:get_value(key_cb, Options, ssh_file), - - #ssh{role = Role, - c_vsn = Vsn, - c_version = Version, - key_cb = KeyCb, - io_cb = IOCb, - userauth_quiet_mode = proplists:get_value(quiet_mode, Options, false), - opts = Options, - userauth_supported_methods = AuthMethods, - peer = {PeerName, PeerAddr}, - available_host_keys = supported_host_keys(Role, KeyCb, Options), - random_length_padding = proplists:get_value(max_random_length_padding, - Options, - (#ssh{})#ssh.random_length_padding) - }; - -init_ssh(server = Role, Vsn, Version, Options, Socket) -> - AuthMethods = proplists:get_value(auth_methods, Options, - ?SUPPORTED_AUTH_METHODS), - AuthMethodsAsList = string:tokens(AuthMethods, ","), - {ok, PeerAddr} = inet:peername(Socket), - KeyCb = proplists:get_value(key_cb, Options, ssh_file), - - #ssh{role = Role, - s_vsn = Vsn, - s_version = Version, - key_cb = KeyCb, - io_cb = proplists:get_value(io_cb, Options, ssh_io), - opts = Options, - userauth_supported_methods = AuthMethods, - userauth_methods = AuthMethodsAsList, - kb_tries_left = 3, - peer = {undefined, PeerAddr}, - available_host_keys = supported_host_keys(Role, KeyCb, Options), - random_length_padding = proplists:get_value(max_random_length_padding, - Options, - (#ssh{})#ssh.random_length_padding) - }. +%%-------------------------------------------------------------------- +%% "Invert" the Role +peer_role(client) -> server; +peer_role(server) -> client. + +%%-------------------------------------------------------------------- +%% StateName to Role +role({_,Role}) -> Role; +role({_,Role,_}) -> Role. +%%-------------------------------------------------------------------- +%% Check the StateName to see if we are in the renegotiation phase +renegotiation({_,_,ReNeg}) -> ReNeg == renegotiation; +renegotiation(_) -> false. + +%%-------------------------------------------------------------------- supported_host_keys(client, _, Options) -> try - case proplists:get_value(public_key, + case proplists:get_value(public_key, proplists:get_value(preferred_algorithms,Options,[]) ) of - undefined -> + undefined -> ssh_transport:default_algorithms(public_key); L -> L -- (L--ssh_transport:default_algorithms(public_key)) @@ -1311,7 +1458,7 @@ supported_host_keys(client, _, Options) -> {stop, {shutdown, Reason}} end; supported_host_keys(server, KeyCb, Options) -> - [atom_to_list(A) || A <- proplists:get_value(public_key, + [atom_to_list(A) || A <- proplists:get_value(public_key, proplists:get_value(preferred_algorithms,Options,[]), ssh_transport:default_algorithms(public_key) ), @@ -1322,10 +1469,16 @@ supported_host_keys(server, KeyCb, Options) -> available_host_key(KeyCb, Alg, Opts) -> element(1, catch KeyCb:host_key(Alg, Opts)) == ok. -send_msg(Msg, #state{socket = Socket, transport_cb = Transport}) -> - Transport:send(Socket, Msg). -handle_version({2, 0} = NumVsn, StrVsn, Ssh0) -> +send_msg(Msg, State=#data{ssh_params=Ssh0}) when is_tuple(Msg) -> + {Bytes, Ssh} = ssh_transport:ssh_packet(Msg, Ssh0), + send_bytes(Bytes, State), + State#data{ssh_params=Ssh}. + +send_bytes(Bytes, #data{socket = Socket, transport_cb = Transport}) -> + Transport:send(Socket, Bytes). + +handle_version({2, 0} = NumVsn, StrVsn, Ssh0) -> Ssh = counterpart_versions(NumVsn, StrVsn, Ssh0), {ok, Ssh}; handle_version(_,_,_) -> @@ -1336,419 +1489,185 @@ string_version(#ssh{role = client, c_version = Vsn}) -> string_version(#ssh{role = server, s_version = Vsn}) -> Vsn. -send_event(FsmPid, Event) -> - gen_fsm:send_event(FsmPid, Event). -send_all_state_event(FsmPid, Event) -> - gen_fsm:send_all_state_event(FsmPid, Event). +cast(FsmPid, Event) -> + gen_statem:cast(FsmPid, Event). -sync_send_all_state_event(FsmPid, Event) -> - sync_send_all_state_event(FsmPid, Event, infinity). +call(FsmPid, Event) -> + call(FsmPid, Event, infinity). -sync_send_all_state_event(FsmPid, Event, Timeout) -> - try gen_fsm:sync_send_all_state_event(FsmPid, Event, Timeout) of - {closed, _Channel} -> +call(FsmPid, Event, Timeout) -> + try gen_statem:call(FsmPid, Event, Timeout) of + {closed, _R} -> + {error, closed}; + {killed, _R} -> {error, closed}; Result -> Result catch - exit:{noproc, _} -> + exit:{noproc, _R} -> {error, closed}; - exit:{normal, _} -> + exit:{normal, _R} -> {error, closed}; - exit:{{shutdown, _},_} -> + exit:{{shutdown, _R},_} -> {error, closed} end. -%% simulate send_all_state_event(self(), Event) -event(#ssh_msg_disconnect{} = Event, StateName, State) -> - handle_event(Event, StateName, State); -event(#ssh_msg_ignore{} = Event, StateName, State) -> - handle_event(Event, StateName, State); -event(#ssh_msg_debug{} = Event, StateName, State) -> - handle_event(Event, StateName, State); -event(#ssh_msg_unimplemented{} = Event, StateName, State) -> - handle_event(Event, StateName, State); -%% simulate send_event(self(), Event) -event(Event, StateName, State) -> - try - ?MODULE:StateName(Event, State) + +handle_connection_msg(Msg, StateName, State0 = + #data{starter = User, + connection_state = Connection0, + event_queue = Qev0}) -> + Renegotiation = renegotiation(StateName), + Role = role(StateName), + try ssh_connection:handle_msg(Msg, Connection0, Role) of + {{replies, Replies}, Connection} -> + case StateName of + {connected,_} -> + {Repls, State} = send_replies(Replies, + State0#data{connection_state=Connection}), + {keep_state, State, Repls}; + _ -> + {ConnReplies, Replies} = + lists:splitwith(fun not_connected_filter/1, Replies), + {Repls, State} = send_replies(Replies, + State0#data{event_queue = Qev0 ++ ConnReplies}), + {keep_state, State, Repls} + end; + + {noreply, Connection} -> + {keep_state, State0#data{connection_state = Connection}}; + + {disconnect, Reason0, {{replies, Replies}, Connection}} -> + {Repls,State} = send_replies(Replies, State0#data{connection_state = Connection}), + case {Reason0,Role} of + {{_, Reason}, client} when ((StateName =/= {connected,client}) and (not Renegotiation)) -> + User ! {self(), not_connected, Reason}; + _ -> + ok + end, + {stop, {shutdown,normal}, Repls, State#data{connection_state = Connection}} + catch - throw:#ssh_msg_disconnect{} = DisconnectMsg -> - handle_disconnect(DisconnectMsg, State); - throw:{ErrorToDisplay, #ssh_msg_disconnect{} = DisconnectMsg} -> - handle_disconnect(DisconnectMsg, State, ErrorToDisplay); - _C:_Error -> - handle_disconnect(#ssh_msg_disconnect{code = error_code(StateName), - description = "Invalid state", - language = "en"}, State) + _:Error -> + {disconnect, _Reason, {{replies, Replies}, Connection}} = + ssh_connection:handle_msg( + #ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, + description = "Internal error"}, + Connection0, Role), + {Repls,State} = send_replies(Replies, State0#data{connection_state = Connection}), + {stop, {shutdown,Error}, Repls, State#data{connection_state = Connection}} end. -error_code(key_exchange) -> - ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED; -error_code(new_keys) -> - ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED; -error_code(_) -> - ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE. - -generate_event(<<?BYTE(Byte), _/binary>> = Msg, StateName, - #state{ - role = Role, - starter = User, - renegotiate = Renegotiation, - connection_state = Connection0} = State0, EncData) - when Byte == ?SSH_MSG_GLOBAL_REQUEST; - Byte == ?SSH_MSG_REQUEST_SUCCESS; - Byte == ?SSH_MSG_REQUEST_FAILURE; - Byte == ?SSH_MSG_CHANNEL_OPEN; - Byte == ?SSH_MSG_CHANNEL_OPEN_CONFIRMATION; - Byte == ?SSH_MSG_CHANNEL_OPEN_FAILURE; - Byte == ?SSH_MSG_CHANNEL_WINDOW_ADJUST; - Byte == ?SSH_MSG_CHANNEL_DATA; - Byte == ?SSH_MSG_CHANNEL_EXTENDED_DATA; - Byte == ?SSH_MSG_CHANNEL_EOF; - Byte == ?SSH_MSG_CHANNEL_CLOSE; - Byte == ?SSH_MSG_CHANNEL_REQUEST; - Byte == ?SSH_MSG_CHANNEL_SUCCESS; - Byte == ?SSH_MSG_CHANNEL_FAILURE -> - try - ssh_message:decode(Msg) - of - ConnectionMsg -> - State1 = generate_event_new_state(State0, EncData), - try ssh_connection:handle_msg(ConnectionMsg, Connection0, Role) of - {{replies, Replies0}, Connection} -> - if StateName == connected -> - Replies = Replies0, - State2 = State1; - true -> - {ConnReplies, Replies} = - lists:splitwith(fun not_connected_filter/1, Replies0), - Q = State1#state.event_queue ++ ConnReplies, - State2 = State1#state{ event_queue = Q } - end, - State = send_replies(Replies, State2#state{connection_state = Connection}), - {next_state, StateName, next_packet(State)}; - {noreply, Connection} -> - {next_state, StateName, next_packet(State1#state{connection_state = Connection})}; - {disconnect, {_, Reason}, {{replies, Replies}, Connection}} when - Role == client andalso ((StateName =/= connected) and (not Renegotiation)) -> - State = send_replies(Replies, State1#state{connection_state = Connection}), - User ! {self(), not_connected, Reason}, - {stop, {shutdown, normal}, - next_packet(State#state{connection_state = Connection})}; - {disconnect, _Reason, {{replies, Replies}, Connection}} -> - State = send_replies(Replies, State1#state{connection_state = Connection}), - {stop, {shutdown, normal}, State#state{connection_state = Connection}} - catch - _:Error -> - {disconnect, _Reason, {{replies, Replies}, Connection}} = - ssh_connection:handle_msg( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_BY_APPLICATION, - description = "Internal error", - language = "en"}, Connection0, Role), - State = send_replies(Replies, State1#state{connection_state = Connection}), - {stop, {shutdown, Error}, State#state{connection_state = Connection}} - end - catch - _:_ -> - handle_disconnect( - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "Bad packet received", - language = ""}, State0) - end; -generate_event(Msg, StateName, State0, EncData) -> - try - Event = ssh_message:decode(set_prefix_if_trouble(Msg,State0)), - State = generate_event_new_state(State0, EncData), - case Event of - #ssh_msg_kexinit{} -> - %% We need payload for verification later. - event({Event, Msg}, StateName, State); - _ -> - event(Event, StateName, State) - end - catch - _C:_E -> - DisconnectMsg = - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "Encountered unexpected input", - language = "en"}, - handle_disconnect(DisconnectMsg, State0) - end. - - -set_prefix_if_trouble(Msg = <<?BYTE(Op),_/binary>>, #state{ssh_params=SshParams}) +set_kex_overload_prefix(Msg = <<?BYTE(Op),_/binary>>, #data{ssh_params=SshParams}) when Op == 30; Op == 31 -> case catch atom_to_list(kex(SshParams)) of - "ecdh-sha2-" ++ _ -> + "ecdh-sha2-" ++ _ -> <<"ecdh",Msg/binary>>; "diffie-hellman-group-exchange-" ++ _ -> <<"dh_gex",Msg/binary>>; "diffie-hellman-group" ++ _ -> <<"dh",Msg/binary>>; - _ -> + _ -> Msg end; -set_prefix_if_trouble(Msg, _) -> +set_kex_overload_prefix(Msg, _) -> Msg. kex(#ssh{algorithms=#alg{kex=Kex}}) -> Kex; kex(_) -> undefined. +cache(#data{connection_state=C}) -> C#connection.channel_cache. + -handle_request(ChannelPid, ChannelId, Type, Data, WantReply, From, - #state{connection_state = - #connection{channel_cache = Cache}} = State0) -> - case ssh_channel:cache_lookup(Cache, ChannelId) of +%%%---------------------------------------------------------------- +handle_request(ChannelPid, ChannelId, Type, Data, WantReply, From, D) -> + case ssh_channel:cache_lookup(cache(D), ChannelId) of #channel{remote_id = Id} = Channel -> - update_sys(Cache, Channel, Type, ChannelPid), - Msg = ssh_connection:channel_request_msg(Id, Type, - WantReply, Data), - Replies = [{connection_reply, Msg}], - State = add_request(WantReply, ChannelId, From, State0), - {{replies, Replies}, State}; + update_sys(cache(D), Channel, Type, ChannelPid), + send_msg(ssh_connection:channel_request_msg(Id, Type, WantReply, Data), + add_request(WantReply, ChannelId, From, D)); undefined -> - {{replies, []}, State0} + D end. -handle_request(ChannelId, Type, Data, WantReply, From, - #state{connection_state = - #connection{channel_cache = Cache}} = State0) -> - case ssh_channel:cache_lookup(Cache, ChannelId) of - #channel{remote_id = Id} -> - Msg = ssh_connection:channel_request_msg(Id, Type, - WantReply, Data), - Replies = [{connection_reply, Msg}], - State = add_request(WantReply, ChannelId, From, State0), - {{replies, Replies}, State}; +handle_request(ChannelId, Type, Data, WantReply, From, D) -> + case ssh_channel:cache_lookup(cache(D), ChannelId) of + #channel{remote_id = Id} -> + send_msg(ssh_connection:channel_request_msg(Id, Type, WantReply, Data), + add_request(WantReply, ChannelId, From, D)); undefined -> - {{replies, []}, State0} - end. - -handle_global_request({global_request, ChannelPid, - "tcpip-forward" = Type, WantReply, - <<?UINT32(IPLen), - IP:IPLen/binary, ?UINT32(Port)>> = Data}, - #state{connection_state = - #connection{channel_cache = Cache} - = Connection0} = State) -> - ssh_channel:cache_update(Cache, #channel{user = ChannelPid, - type = "forwarded-tcpip", - sys = none}), - Connection = ssh_connection:bind(IP, Port, ChannelPid, Connection0), - Msg = ssh_connection:global_request_msg(Type, WantReply, Data), - send_replies([{connection_reply, Msg}], State#state{connection_state = Connection}); - -handle_global_request({global_request, _Pid, "cancel-tcpip-forward" = Type, - WantReply, <<?UINT32(IPLen), - IP:IPLen/binary, ?UINT32(Port)>> = Data}, - #state{connection_state = Connection0} = State) -> - Connection = ssh_connection:unbind(IP, Port, Connection0), - Msg = ssh_connection:global_request_msg(Type, WantReply, Data), - send_replies([{connection_reply, Msg}], State#state{connection_state = Connection}); - -handle_global_request({global_request, _, "cancel-tcpip-forward" = Type, - WantReply, Data}, State) -> - Msg = ssh_connection:global_request_msg(Type, WantReply, Data), - send_replies([{connection_reply, Msg}], State). - -handle_idle_timeout(#state{opts = Opts}) -> - case proplists:get_value(idle_time, Opts, infinity) of - infinity -> - ok; - IdleTime -> - erlang:send_after(IdleTime, self(), {check_cache, [], []}) + D end. -handle_channel_down(ChannelPid, #state{connection_state = - #connection{channel_cache = Cache}} = - State) -> +%%%---------------------------------------------------------------- +handle_channel_down(ChannelPid, D) -> ssh_channel:cache_foldl( fun(Channel, Acc) when Channel#channel.user == ChannelPid -> - ssh_channel:cache_delete(Cache, + ssh_channel:cache_delete(cache(D), Channel#channel.local_id), Acc; (_,Acc) -> Acc - end, [], Cache), - {{replies, []}, check_cache(State, Cache)}. + end, [], cache(D)), + {{replies, []}, cache_check_set_idle_timer(D)}. + update_sys(Cache, Channel, Type, ChannelPid) -> ssh_channel:cache_update(Cache, Channel#channel{sys = Type, user = ChannelPid}). + add_request(false, _ChannelId, _From, State) -> State; -add_request(true, ChannelId, From, #state{connection_state = - #connection{requests = Requests0} = - Connection} = State) -> +add_request(true, ChannelId, From, #data{connection_state = + #connection{requests = Requests0} = + Connection} = State) -> Requests = [{ChannelId, From} | Requests0], - State#state{connection_state = Connection#connection{requests = Requests}}. + State#data{connection_state = Connection#connection{requests = Requests}}. -new_channel_id(#state{connection_state = #connection{channel_id_seed = Id} = - Connection} +new_channel_id(#data{connection_state = #connection{channel_id_seed = Id} = + Connection} = State) -> - {Id, State#state{connection_state = - Connection#connection{channel_id_seed = Id + 1}}}. - -generate_event_new_state(#state{ssh_params = - #ssh{recv_sequence = SeqNum0} - = Ssh} = State, EncData) -> - SeqNum = ssh_transport:next_seqnum(SeqNum0), - State#state{ssh_params = Ssh#ssh{recv_sequence = SeqNum}, - decoded_data_buffer = <<>>, - encoded_data_buffer = EncData, - undecoded_packet_length = undefined}. - -next_packet(#state{decoded_data_buffer = <<>>, - encoded_data_buffer = Buff, - ssh_params = #ssh{decrypt_block_size = BlockSize}, - socket = Socket, - transport_protocol = Protocol} = State) when Buff =/= <<>> -> - case size(Buff) >= erlang:max(8, BlockSize) of - true -> - %% Enough data from the next packet has been received to - %% decode the length indicator, fake a socket-recive - %% message so that the data will be processed - self() ! {Protocol, Socket, <<>>}; - false -> - inet:setopts(Socket, [{active, once}]) - end, - State; - -next_packet(#state{socket = Socket} = State) -> - inet:setopts(Socket, [{active, once}]), - State. - -after_new_keys(#state{renegotiate = true} = State) -> - State1 = State#state{renegotiate = false, event_queue = []}, - lists:foldr(fun after_new_keys_events/2, {next_state, connected, State1}, State#state.event_queue); -after_new_keys(#state{renegotiate = false, - ssh_params = #ssh{role = client} = Ssh0} = State) -> - {Msg, Ssh} = ssh_auth:service_request_msg(Ssh0), - send_msg(Msg, State), - {next_state, service_request, State#state{ssh_params = Ssh}}; -after_new_keys(#state{renegotiate = false, - ssh_params = #ssh{role = server}} = State) -> - {next_state, service_request, State}. - -after_new_keys_events({sync, _Event, From}, {stop, _Reason, _StateData}=Terminator) -> - gen_fsm:reply(From, {error, closed}), - Terminator; -after_new_keys_events(_, {stop, _Reason, _StateData}=Terminator) -> - Terminator; -after_new_keys_events({sync, Event, From}, {next_state, StateName, StateData}) -> - case handle_sync_event(Event, From, StateName, StateData) of - {reply, Reply, NextStateName, NewStateData} -> - gen_fsm:reply(From, Reply), - {next_state, NextStateName, NewStateData}; - {next_state, NextStateName, NewStateData}-> - {next_state, NextStateName, NewStateData}; - {stop, Reason, Reply, NewStateData} -> - gen_fsm:reply(From, Reply), - {stop, Reason, NewStateData} - end; -after_new_keys_events({event, Event}, {next_state, StateName, StateData}) -> - case handle_event(Event, StateName, StateData) of - {next_state, NextStateName, NewStateData}-> - {next_state, NextStateName, NewStateData}; - {stop, Reason, NewStateData} -> - {stop, Reason, NewStateData} - end; -after_new_keys_events({connection_reply, _Data} = Reply, {StateName, State}) -> - NewState = send_replies([Reply], State), - {next_state, StateName, NewState}. - - -handle_disconnect(DisconnectMsg, State) -> - handle_disconnect(own, DisconnectMsg, State). - -handle_disconnect(#ssh_msg_disconnect{} = DisconnectMsg, State, Error) -> - handle_disconnect(own, DisconnectMsg, State, Error); -handle_disconnect(Type, #ssh_msg_disconnect{description = Desc} = Msg, #state{connection_state = Connection0, role = Role} = State0) -> - {disconnect, _, {{replies, Replies}, Connection}} = ssh_connection:handle_msg(Msg, Connection0, Role), - State = send_replies(disconnect_replies(Type, Msg, Replies), State0), - disconnect_fun(Desc, State#state.opts), - {stop, {shutdown, Desc}, State#state{connection_state = Connection}}. - -handle_disconnect(Type, #ssh_msg_disconnect{description = Desc} = Msg, #state{connection_state = Connection0, - role = Role} = State0, ErrorMsg) -> - {disconnect, _, {{replies, Replies}, Connection}} = ssh_connection:handle_msg(Msg, Connection0, Role), - State = send_replies(disconnect_replies(Type, Msg, Replies), State0), - disconnect_fun(Desc, State#state.opts), - {stop, {shutdown, {Desc, ErrorMsg}}, State#state{connection_state = Connection}}. - -disconnect_replies(own, Msg, Replies) -> - [{connection_reply, Msg} | Replies]; -disconnect_replies(peer, _, Replies) -> - Replies. - + {Id, State#data{connection_state = + Connection#connection{channel_id_seed = Id + 1}}}. + +%%%---------------------------------------------------------------- +%% %%% This server/client has decided to disconnect via the state machine: +disconnect(Msg=#ssh_msg_disconnect{description=Description}, _StateName, State0) -> + State = send_msg(Msg, State0), + disconnect_fun(Description, State), +timer:sleep(400), + {stop, {shutdown,Description}, State}. + +%%%---------------------------------------------------------------- counterpart_versions(NumVsn, StrVsn, #ssh{role = server} = Ssh) -> Ssh#ssh{c_vsn = NumVsn , c_version = StrVsn}; counterpart_versions(NumVsn, StrVsn, #ssh{role = client} = Ssh) -> Ssh#ssh{s_vsn = NumVsn , s_version = StrVsn}. -opposite_role(client) -> - server; -opposite_role(server) -> - client. -connected_fun(User, PeerAddr, Method, Opts) -> - case proplists:get_value(connectfun, Opts) of - undefined -> - ok; - Fun -> - catch Fun(User, PeerAddr, Method) - end. - -retry_fun(_, _, undefined, _) -> - ok; - -retry_fun(User, PeerAddr, {error, Reason}, Opts) -> - case proplists:get_value(failfun, Opts) of - undefined -> - ok; - Fun -> - do_retry_fun(Fun, User, PeerAddr, Reason) - end; - -retry_fun(User, PeerAddr, Reason, Opts) -> - case proplists:get_value(infofun, Opts) of - undefined -> - ok; - Fun -> - do_retry_fun(Fun, User, PeerAddr, Reason) - end. - -do_retry_fun(Fun, User, PeerAddr, Reason) -> - case erlang:fun_info(Fun, arity) of - {arity, 2} -> %% Backwards compatible - catch Fun(User, Reason); - {arity, 3} -> - catch Fun(User, PeerAddr, Reason) - end. - ssh_info([], _State, Acc) -> Acc; -ssh_info([client_version | Rest], #state{ssh_params = #ssh{c_vsn = IntVsn, +ssh_info([client_version | Rest], #data{ssh_params = #ssh{c_vsn = IntVsn, c_version = StringVsn}} = State, Acc) -> ssh_info(Rest, State, [{client_version, {IntVsn, StringVsn}} | Acc]); -ssh_info([server_version | Rest], #state{ssh_params =#ssh{s_vsn = IntVsn, +ssh_info([server_version | Rest], #data{ssh_params =#ssh{s_vsn = IntVsn, s_version = StringVsn}} = State, Acc) -> ssh_info(Rest, State, [{server_version, {IntVsn, StringVsn}} | Acc]); -ssh_info([peer | Rest], #state{ssh_params = #ssh{peer = Peer}} = State, Acc) -> +ssh_info([peer | Rest], #data{ssh_params = #ssh{peer = Peer}} = State, Acc) -> ssh_info(Rest, State, [{peer, Peer} | Acc]); -ssh_info([sockname | Rest], #state{socket = Socket} = State, Acc) -> +ssh_info([sockname | Rest], #data{socket = Socket} = State, Acc) -> {ok, SockName} = inet:sockname(Socket), ssh_info(Rest, State, [{sockname, SockName}|Acc]); -ssh_info([user | Rest], #state{auth_user = User} = State, Acc) -> +ssh_info([user | Rest], #data{auth_user = User} = State, Acc) -> ssh_info(Rest, State, [{user, User}|Acc]); ssh_info([ _ | Rest], State, Acc) -> ssh_info(Rest, State, Acc). + ssh_channel_info([], _, Acc) -> Acc; @@ -1765,43 +1684,49 @@ ssh_channel_info([send_window | Rest], #channel{send_window_size = WinSize, ssh_channel_info([ _ | Rest], Channel, Acc) -> ssh_channel_info(Rest, Channel, Acc). + log_error(Reason) -> - Report = io_lib:format("Erlang ssh connection handler failed with reason: " - "~p ~n, Stacktrace: ~p ~n", - [Reason, erlang:get_stacktrace()]), - error_logger:error_report(Report), - "Internal error". - -not_connected_filter({connection_reply, _Data}) -> - true; -not_connected_filter(_) -> - false. - -send_replies([], State) -> - State; -send_replies([{connection_reply, Data} | Rest], #state{ssh_params = Ssh0} = State) -> - {Packet, Ssh} = ssh_transport:ssh_packet(Data, Ssh0), - send_msg(Packet, State), - send_replies(Rest, State#state{ssh_params = Ssh}); -send_replies([Msg | Rest], State) -> - catch send_reply(Msg), - send_replies(Rest, State). - -send_reply({channel_data, Pid, Data}) -> - Pid ! {ssh_cm, self(), Data}; -send_reply({channel_requst_reply, From, Data}) -> - gen_fsm:reply(From, Data); -send_reply({flow_control, Cache, Channel, From, Msg}) -> + Report = io_lib:format("Erlang ssh connection handler failed with reason:~n" + " ~p~n" + "Stacktrace:~n" + " ~p~n", + [Reason, erlang:get_stacktrace()]), + error_logger:error_report(Report). + + +%%%---------------------------------------------------------------- +not_connected_filter({connection_reply, _Data}) -> true; +not_connected_filter(_) -> false. + +%%%---------------------------------------------------------------- +send_replies(Repls, State) -> + lists:foldl(fun get_repl/2, + {[],State}, + Repls). + +get_repl({connection_reply,Msg}, {CallRepls,S}) -> + {CallRepls, send_msg(Msg,S)}; +get_repl({channel_data,undefined,_Data}, Acc) -> + Acc; +get_repl({channel_data,Pid,Data}, Acc) -> + Pid ! {ssh_cm, self(), Data}, + Acc; +get_repl({channel_request_reply,From,Data}, {CallRepls,S}) -> + {[{reply,From,Data}|CallRepls], S}; +get_repl({flow_control,Cache,Channel,From,Msg}, {CallRepls,S}) -> ssh_channel:cache_update(Cache, Channel#channel{flow_control = undefined}), - gen_fsm:reply(From, Msg); -send_reply({flow_control, From, Msg}) -> - gen_fsm:reply(From, Msg). + {[{reply,From,Msg}|CallRepls], S}; +get_repl({flow_control,From,Msg}, {CallRepls,S}) -> + {[{reply,From,Msg}|CallRepls], S}; +get_repl(noreply, Acc) -> + Acc; +get_repl(X, Acc) -> + exit({get_repl,X,Acc}). -disconnect_fun({disconnect,Msg}, Opts) -> - disconnect_fun(Msg, Opts); -disconnect_fun(_, undefined) -> - ok; -disconnect_fun(Reason, Opts) -> +%%%---------------------------------------------------------------- +disconnect_fun({disconnect,Msg}, D) -> + disconnect_fun(Msg, D); +disconnect_fun(Reason, #data{opts=Opts}) -> case proplists:get_value(disconnectfun, Opts) of undefined -> ok; @@ -1809,50 +1734,137 @@ disconnect_fun(Reason, Opts) -> catch Fun(Reason) end. -unexpected_fun(UnexpectedMessage, Opts, #ssh{peer={_,Peer}}) -> +unexpected_fun(UnexpectedMessage, #data{opts = Opts, + ssh_params = #ssh{peer = {_,Peer} } + } ) -> case proplists:get_value(unexpectedfun, Opts) of undefined -> report; Fun -> - catch Fun(UnexpectedMessage, Peer) + catch Fun(UnexpectedMessage, Peer) end. -check_cache(#state{opts = Opts} = State, Cache) -> - %% Check the number of entries in Cache - case proplists:get_value(size, ets:info(Cache)) of - 0 -> - case proplists:get_value(idle_time, Opts, infinity) of - infinity -> - State; - Time -> - handle_idle_timer(Time, State) - end; +debug_fun(#ssh_msg_debug{always_display = Display, + message = DbgMsg, + language = Lang}, + #data{opts = Opts}) -> + case proplists:get_value(ssh_msg_debug_fun, Opts) of + undefined -> + ok; + Fun -> + catch Fun(self(), Display, DbgMsg, Lang) + end. + + +connected_fun(User, Method, #data{ssh_params = #ssh{peer = {_,Peer}}, + opts = Opts}) -> + case proplists:get_value(connectfun, Opts) of + undefined -> + ok; + Fun -> + catch Fun(User, Peer, Method) + end. + +retry_fun(_, undefined, _) -> + ok; +retry_fun(User, Reason, #data{ssh_params = #ssh{opts = Opts, + peer = {_,Peer} + }}) -> + {Tag,Info} = + case Reason of + {error, Error} -> + {failfun, Error}; + _ -> + {infofun, Reason} + end, + Fun = proplists:get_value(Tag, Opts, fun(_,_)-> ok end), + try erlang:fun_info(Fun, arity) + of + {arity, 2} -> %% Backwards compatible + catch Fun(User, Info); + {arity, 3} -> + catch Fun(User, Peer, Info); _ -> - State + ok + catch + _:_ -> + ok + end. + +%%%---------------------------------------------------------------- +%%% Cache idle timer that closes the connection if there are no +%%% channels open for a while. + +cache_init_idle_timer(D) -> + case proplists:get_value(idle_time, D#data.opts, infinity) of + infinity -> + D#data{idle_timer_value = infinity, + idle_timer_ref = infinity % A flag used later... + }; + IdleTime -> + %% We dont want to set the timeout on first connect + D#data{idle_timer_value = IdleTime} end. -handle_idle_timer(Time, #state{idle_timer_ref = undefined} = State) -> - TimerRef = erlang:send_after(Time, self(), {'EXIT', [], "Timeout"}), - State#state{idle_timer_ref=TimerRef}; -handle_idle_timer(_, State) -> - State. - -remove_timer_ref(State) -> - case State#state.idle_timer_ref of - infinity -> %% If the timer is not activated - State; - undefined -> %% If we already has cancelled the timer - State; - TimerRef -> %% Timer is active + +cache_check_set_idle_timer(D = #data{idle_timer_ref = undefined, + idle_timer_value = IdleTime}) -> + %% No timer set - shall we set one? + case ssh_channel:cache_info(num_entries, cache(D)) of + 0 when IdleTime == infinity -> + %% No. Meaningless to set a timer that fires in an infinite time... + D; + 0 -> + %% Yes, we'll set one since the cache is empty and it should not + %% be that for a specified time + D#data{idle_timer_ref = + erlang:send_after(IdleTime, self(), {'EXIT',[],"Timeout"})}; + _ -> + %% No - there are entries in the cache + D + end; +cache_check_set_idle_timer(D) -> + %% There is already a timer set or the timeout time is infinite + D. + + +cache_cancel_idle_timer(D) -> + case D#data.idle_timer_ref of + infinity -> + %% The timer is not activated + D; + undefined -> + %% The timer is already cancelled + D; + TimerRef -> + %% The timer is active erlang:cancel_timer(TimerRef), - State#state{idle_timer_ref = undefined} + D#data{idle_timer_ref = undefined} end. -socket_control(Socket, Pid, Transport) -> - case Transport:controlling_process(Socket, Pid) of + +cache_request_idle_timer_check(D = #data{idle_timer_value = infinity}) -> + D; +cache_request_idle_timer_check(D = #data{idle_timer_value = IdleTime}) -> + erlang:send_after(IdleTime, self(), check_cache), + D. + +%%%---------------------------------------------------------------- +start_channel_request_timer(_,_, infinity) -> + ok; +start_channel_request_timer(Channel, From, Time) -> + erlang:send_after(Time, self(), {timeout, {Channel, From}}). + +%%%---------------------------------------------------------------- +%%% Connection start and initalization helpers + +socket_control(Socket, Pid, Options) -> + {_, TransportCallback, _} = % For example {_,gen_tcp,_} + proplists:get_value(transport, Options, ?DefaultTransport), + case TransportCallback:controlling_process(Socket, Pid) of ok -> - send_event(Pid, socket_control); + gen_statem:cast(Pid, socket_control); {error, Reason} -> {error, Reason} end. @@ -1881,16 +1893,3 @@ handshake(Pid, Ref, Timeout) -> {error, timeout} end. -start_timeout(_,_, infinity) -> - ok; -start_timeout(Channel, From, Time) -> - erlang:send_after(Time, self(), {timeout, {Channel, From}}). - -getopt(Opt, Socket) -> - case inet:getopts(Socket, [Opt]) of - {ok, [{Opt, Value}]} -> - {ok, Value}; - Other -> - {error, {unexpected_getopts_return, Other}} - end. - diff --git a/lib/ssh/src/ssh_info.erl b/lib/ssh/src/ssh_info.erl index 67130d5eac..0c24c09887 100644 --- a/lib/ssh/src/ssh_info.erl +++ b/lib/ssh/src/ssh_info.erl @@ -37,7 +37,7 @@ print() -> io:format("~s", [string()]). print(File) when is_list(File) -> - {ok,D} = file:open(File, write), + {ok,D} = file:open(File, [write]), print(D), file:close(D); print(D) -> diff --git a/lib/ssh/src/ssh_message.erl b/lib/ssh/src/ssh_message.erl index 65754956aa..db80d4c9e3 100644 --- a/lib/ssh/src/ssh_message.erl +++ b/lib/ssh/src/ssh_message.erl @@ -50,13 +50,7 @@ -define(Empint(X), (ssh_bits:mpint(X))/binary ). -define(Ebinary(X), ?STRING(X) ). -%% encode(Msg) -> -%% try encode1(Msg) -%% catch -%% C:E -> -%% io:format('***********************~n~p:~p ~p~n',[C,E,Msg]), -%% error(E) -%% end. +-define(unicode_list(B), unicode:characters_to_list(B)). encode(#ssh_msg_global_request{ name = Name, @@ -176,7 +170,7 @@ encode(#ssh_msg_userauth_pk_ok{ encode(#ssh_msg_userauth_passwd_changereq{prompt = Prompt, languge = Lang })-> - <<?Ebyte(?SSH_MSG_USERAUTH_PASSWD_CHANGEREQ), ?Estring(Prompt), ?Estring(Lang)>>; + <<?Ebyte(?SSH_MSG_USERAUTH_PASSWD_CHANGEREQ), ?Estring_utf8(Prompt), ?Estring(Lang)>>; encode(#ssh_msg_userauth_info_request{ name = Name, @@ -184,14 +178,14 @@ encode(#ssh_msg_userauth_info_request{ language_tag = Lang, num_prompts = NumPromtps, data = Data}) -> - <<?Ebyte(?SSH_MSG_USERAUTH_INFO_REQUEST), ?Estring(Name), ?Estring(Inst), ?Estring(Lang), + <<?Ebyte(?SSH_MSG_USERAUTH_INFO_REQUEST), ?Estring_utf8(Name), ?Estring_utf8(Inst), ?Estring(Lang), ?Euint32(NumPromtps), ?'E...'(Data)>>; encode(#ssh_msg_userauth_info_response{ num_responses = Num, data = Data}) -> lists:foldl(fun %%("", Acc) -> Acc; % commented out since it seem wrong - (Response, Acc) -> <<Acc/binary, ?Estring(Response)>> + (Response, Acc) -> <<Acc/binary, ?Estring_utf8(Response)>> end, <<?Ebyte(?SSH_MSG_USERAUTH_INFO_RESPONSE), ?Euint32(Num)>>, Data); @@ -201,17 +195,17 @@ encode(#ssh_msg_disconnect{ description = Desc, language = Lang }) -> - <<?Ebyte(?SSH_MSG_DISCONNECT), ?Euint32(Code), ?Estring(Desc), ?Estring(Lang)>>; + <<?Ebyte(?SSH_MSG_DISCONNECT), ?Euint32(Code), ?Estring_utf8(Desc), ?Estring(Lang)>>; encode(#ssh_msg_service_request{ name = Service }) -> - <<?Ebyte(?SSH_MSG_SERVICE_REQUEST), ?Estring(Service)>>; + <<?Ebyte(?SSH_MSG_SERVICE_REQUEST), ?Estring_utf8(Service)>>; encode(#ssh_msg_service_accept{ name = Service }) -> - <<?Ebyte(?SSH_MSG_SERVICE_ACCEPT), ?Estring(Service)>>; + <<?Ebyte(?SSH_MSG_SERVICE_ACCEPT), ?Estring_utf8(Service)>>; encode(#ssh_msg_newkeys{}) -> <<?Ebyte(?SSH_MSG_NEWKEYS)>>; @@ -283,7 +277,7 @@ encode(#ssh_msg_kex_ecdh_reply{public_host_key = Key, q_s = Q_s, h_sig = Sign}) <<?Ebyte(?SSH_MSG_KEX_ECDH_REPLY), ?Ebinary(EncKey), ?Empint(Q_s), ?Ebinary(EncSign)>>; encode(#ssh_msg_ignore{data = Data}) -> - <<?Ebyte(?SSH_MSG_IGNORE), ?Estring(Data)>>; + <<?Ebyte(?SSH_MSG_IGNORE), ?Estring_utf8(Data)>>; encode(#ssh_msg_unimplemented{sequence = Seq}) -> <<?Ebyte(?SSH_MSG_UNIMPLEMENTED), ?Euint32(Seq)>>; @@ -291,7 +285,7 @@ encode(#ssh_msg_unimplemented{sequence = Seq}) -> encode(#ssh_msg_debug{always_display = Bool, message = Msg, language = Lang}) -> - <<?Ebyte(?SSH_MSG_DEBUG), ?Eboolean(Bool), ?Estring(Msg), ?Estring(Lang)>>. + <<?Ebyte(?SSH_MSG_DEBUG), ?Eboolean(Bool), ?Estring_utf8(Msg), ?Estring(Lang)>>. %% Connection Messages @@ -330,7 +324,7 @@ decode(<<?BYTE(?SSH_MSG_CHANNEL_OPEN_FAILURE), ?UINT32(Recipient), ?UINT32(Reas #ssh_msg_channel_open_failure{ recipient_channel = Recipient, reason = Reason, - description = unicode:characters_to_list(Desc), + description = ?unicode_list(Desc), lang = Lang }; decode(<<?BYTE(?SSH_MSG_CHANNEL_WINDOW_ADJUST), ?UINT32(Recipient), ?UINT32(Bytes)>>) -> @@ -363,7 +357,7 @@ decode(<<?BYTE(?SSH_MSG_CHANNEL_REQUEST), ?UINT32(Recipient), ?DEC_BIN(RequestType,__0), ?BYTE(Bool), Data/binary>>) -> #ssh_msg_channel_request{ recipient_channel = Recipient, - request_type = unicode:characters_to_list(RequestType), + request_type = ?unicode_list(RequestType), want_reply = erl_boolean(Bool), data = Data }; @@ -381,9 +375,9 @@ decode(<<?BYTE(?SSH_MSG_USERAUTH_REQUEST), ?DEC_BIN(User,__0), ?DEC_BIN(Service,__1), ?DEC_BIN(Method,__2), Data/binary>>) -> #ssh_msg_userauth_request{ - user = unicode:characters_to_list(User), - service = unicode:characters_to_list(Service), - method = unicode:characters_to_list(Method), + user = ?unicode_list(User), + service = ?unicode_list(Service), + method = ?unicode_list(Method), data = Data }; @@ -391,7 +385,7 @@ decode(<<?BYTE(?SSH_MSG_USERAUTH_FAILURE), ?DEC_BIN(Auths,__0), ?BYTE(Bool)>>) -> #ssh_msg_userauth_failure { - authentications = unicode:characters_to_list(Auths), + authentications = ?unicode_list(Auths), partial_success = erl_boolean(Bool) }; @@ -493,18 +487,18 @@ decode(<<"ecdh",?BYTE(?SSH_MSG_KEX_ECDH_REPLY), decode(<<?SSH_MSG_SERVICE_REQUEST, ?DEC_BIN(Service,__0)>>) -> #ssh_msg_service_request{ - name = unicode:characters_to_list(Service) + name = ?unicode_list(Service) }; decode(<<?SSH_MSG_SERVICE_ACCEPT, ?DEC_BIN(Service,__0)>>) -> #ssh_msg_service_accept{ - name = unicode:characters_to_list(Service) + name = ?unicode_list(Service) }; decode(<<?BYTE(?SSH_MSG_DISCONNECT), ?UINT32(Code), ?DEC_BIN(Desc,__0), ?DEC_BIN(Lang,__1)>>) -> #ssh_msg_disconnect{ code = Code, - description = unicode:characters_to_list(Desc), + description = ?unicode_list(Desc), language = Lang }; @@ -512,7 +506,7 @@ decode(<<?BYTE(?SSH_MSG_DISCONNECT), ?UINT32(Code), ?DEC_BIN(Desc,__0), ?DEC_BIN decode(<<?BYTE(?SSH_MSG_DISCONNECT), ?UINT32(Code), ?DEC_BIN(Desc,__0)>>) -> #ssh_msg_disconnect{ code = Code, - description = unicode:characters_to_list(Desc), + description = ?unicode_list(Desc), language = <<"en">> }; @@ -554,7 +548,7 @@ decode_kex_init(<<?BYTE(Bool)>>, Acc, 0) -> X = 0, list_to_tuple(lists:reverse([X, erl_boolean(Bool) | Acc])); decode_kex_init(<<?DEC_BIN(Data,__0), Rest/binary>>, Acc, N) -> - Names = string:tokens(unicode:characters_to_list(Data), ","), + Names = string:tokens(?unicode_list(Data), ","), decode_kex_init(Rest, [Names | Acc], N -1). diff --git a/lib/ssh/src/ssh_no_io.erl b/lib/ssh/src/ssh_no_io.erl index 8144aac66e..1da257ed99 100644 --- a/lib/ssh/src/ssh_no_io.erl +++ b/lib/ssh/src/ssh_no_io.erl @@ -27,27 +27,39 @@ -export([yes_no/2, read_password/2, read_line/2, format/2]). + +-spec yes_no(any(), any()) -> no_return(). + yes_no(_, _) -> - throw({{no_io_allowed, yes_no}, - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = "User interaction is not allowed", - language = "en"}}). + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + description = "User interaction is not allowed"}, + {no_io_allowed, yes_no}). + + +-spec read_password(any(), any()) -> no_return(). read_password(_, _) -> - throw({{no_io_allowed, read_password}, - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = "User interaction is not allowed", - language = "en"}}). + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + description = "User interaction is not allowed"}, + {no_io_allowed, read_password}). + + +-spec read_line(any(), any()) -> no_return(). read_line(_, _) -> - throw({{no_io_allowed, read_line}, - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = "User interaction is not allowed", - language = "en"}} ). + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + description = "User interaction is not allowed"}, + {no_io_allowed, read_line}). + + +-spec format(any(), any()) -> no_return(). format(_, _) -> - throw({{no_io_allowed, format}, - #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, - description = "User interaction is not allowed", - language = "en"}}). + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{code = ?SSH_DISCONNECT_SERVICE_NOT_AVAILABLE, + description = "User interaction is not allowed"}, + {no_io_allowed, format}). diff --git a/lib/ssh/src/ssh_system_sup.erl b/lib/ssh/src/ssh_system_sup.erl index 6314671f0d..9a9786a914 100644 --- a/lib/ssh/src/ssh_system_sup.erl +++ b/lib/ssh/src/ssh_system_sup.erl @@ -192,6 +192,9 @@ stop_acceptor(Sup) -> [{Name, AcceptorSup}] = [{SupName, ASup} || {SupName, ASup, _, [ssh_acceptor_sup]} <- supervisor:which_children(Sup)], - supervisor:terminate_child(AcceptorSup, Name). - - + case supervisor:terminate_child(AcceptorSup, Name) of + ok -> + supervisor:delete_child(AcceptorSup, Name); + Error -> + Error + end. diff --git a/lib/ssh/src/ssh_transport.erl b/lib/ssh/src/ssh_transport.erl index c04bd350c7..7cb3b75ac0 100644 --- a/lib/ssh/src/ssh_transport.erl +++ b/lib/ssh/src/ssh_transport.erl @@ -265,7 +265,8 @@ new_keys_message(Ssh0) -> {SshPacket, Ssh} = ssh_packet(#ssh_msg_newkeys{}, Ssh0), {ok, SshPacket, Ssh}. - + + handle_kexinit_msg(#ssh_msg_kexinit{} = CounterPart, #ssh_msg_kexinit{} = Own, #ssh{role = client} = Ssh0) -> {ok, Algoritms} = select_algorithm(client, Own, CounterPart), @@ -275,10 +276,10 @@ handle_kexinit_msg(#ssh_msg_kexinit{} = CounterPart, #ssh_msg_kexinit{} = Own, Ssh0#ssh{algorithms = Algoritms}); _ -> %% TODO: Correct code? - throw(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Selection of key exchange" - " algorithm failed", - language = ""}) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + description = "Selection of key exchange algorithm failed" + }) end; handle_kexinit_msg(#ssh_msg_kexinit{} = CounterPart, #ssh_msg_kexinit{} = Own, @@ -288,10 +289,10 @@ handle_kexinit_msg(#ssh_msg_kexinit{} = CounterPart, #ssh_msg_kexinit{} = Own, true -> {ok, Ssh#ssh{algorithms = Algoritms}}; _ -> - throw(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Selection of key exchange" - " algorithm failed", - language = ""}) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + description = "Selection of key exchange algorithm failed" + }) end. @@ -371,12 +372,12 @@ handle_kexdh_init(#ssh_msg_kexdh_init{e = E}, session_id = sid(Ssh1, H)}}; true -> - throw({{error,bad_e_from_peer}, - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed, 'e' out of bounds", - language = ""} - }) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + description = "Key exchange failed, 'e' out of bounds"}, + {error,bad_e_from_peer} + ) end. handle_kexdh_reply(#ssh_msg_kexdh_reply{public_host_key = PeerPubHostKey, @@ -396,21 +397,20 @@ handle_kexdh_reply(#ssh_msg_kexdh_reply{public_host_key = PeerPubHostKey, exchanged_hash = H, session_id = sid(Ssh, H)}}; Error -> - throw({Error, - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed", - language = "en"} - }) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + description = "Key exchange failed"}, + Error) end; true -> - throw({{error,bad_f_from_peer}, - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed, 'f' out of bounds", - language = ""} - }) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + description = "Key exchange failed, 'f' out of bounds"}, + bad_f_from_peer + ) end. @@ -435,10 +435,11 @@ handle_kex_dh_gex_request(#ssh_msg_kex_dh_gex_request{min = Min0, keyex_info = {Min, Max, NBits} }}; {error,_} -> - throw(#ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "No possible diffie-hellman-group-exchange group found", - language = ""}) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_PROTOCOL_ERROR, + description = "No possible diffie-hellman-group-exchange group found" + }) end; handle_kex_dh_gex_request(#ssh_msg_kex_dh_gex_request_old{n = NBits}, @@ -469,19 +470,19 @@ handle_kex_dh_gex_request(#ssh_msg_kex_dh_gex_request_old{n = NBits}, keyex_info = {-1, -1, NBits} % flag for kex_h hash calc }}; {error,_} -> - throw(#ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "No possible diffie-hellman-group-exchange group found", - language = ""}) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_PROTOCOL_ERROR, + description = "No possible diffie-hellman-group-exchange group found" + }) end; handle_kex_dh_gex_request(_, _) -> - throw({{error,bad_ssh_msg_kex_dh_gex_request}, + ssh_connection_handler:disconnect( #ssh_msg_disconnect{ code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed, bad values in ssh_msg_kex_dh_gex_request", - language = ""} - }). + description = "Key exchange failed, bad values in ssh_msg_kex_dh_gex_request"}, + bad_ssh_msg_kex_dh_gex_request). adjust_gex_min_max(Min0, Max0, Opts) -> @@ -495,10 +496,11 @@ adjust_gex_min_max(Min0, Max0, Opts) -> Min2 =< Max2 -> {Min2, Max2}; Max2 < Min2 -> - throw(#ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "No possible diffie-hellman-group-exchange group possible", - language = ""}) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_PROTOCOL_ERROR, + description = "No possible diffie-hellman-group-exchange group possible" + }) end end. @@ -535,20 +537,18 @@ handle_kex_dh_gex_init(#ssh_msg_kex_dh_gex_init{e = E}, session_id = sid(Ssh, H) }}; true -> - throw({{error,bad_K}, - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed, 'K' out of bounds", - language = ""} - }) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + description = "Key exchange failed, 'K' out of bounds"}, + bad_K) end; true -> - throw({{error,bad_e_from_peer}, - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed, 'e' out of bounds", - language = ""} - }) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + description = "Key exchange failed, 'e' out of bounds"}, + bad_e_from_peer) end. handle_kex_dh_gex_reply(#ssh_msg_kex_dh_gex_reply{public_host_key = PeerPubHostKey, @@ -572,29 +572,28 @@ handle_kex_dh_gex_reply(#ssh_msg_kex_dh_gex_reply{public_host_key = PeerPubHostK exchanged_hash = H, session_id = sid(Ssh, H)}}; _Error -> - throw(#ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed", - language = ""} - ) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + description = "Key exchange failed" + }) end; true -> - throw({{error,bad_K}, - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed, 'K' out of bounds", - language = ""} - }) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + description = "Key exchange failed, 'K' out of bounds"}, + bad_K) end; true -> - throw({{error,bad_f_from_peer}, - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed, 'f' out of bounds", - language = ""} - }) - end. + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + description = "Key exchange failed, 'f' out of bounds"}, + bad_f_from_peer + ) + end. %%%---------------------------------------------------------------- %%% @@ -624,12 +623,11 @@ handle_kex_ecdh_init(#ssh_msg_kex_ecdh_init{q_c = PeerPublic}, session_id = sid(Ssh1, H)}} catch _:_ -> - throw({{error,invalid_peer_public_key}, - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Peer ECDH public key is invalid", - language = ""} - }) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + description = "Peer ECDH public key is invalid"}, + invalid_peer_public_key) end. handle_kex_ecdh_reply(#ssh_msg_kex_ecdh_reply{public_host_key = PeerPubHostKey, @@ -650,21 +648,19 @@ handle_kex_ecdh_reply(#ssh_msg_kex_ecdh_reply{public_host_key = PeerPubHostKey, exchanged_hash = H, session_id = sid(Ssh, H)}}; Error -> - throw({Error, - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Key exchange failed", - language = ""} - }) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + description = "Key exchange failed"}, + Error) end catch _:_ -> - throw({{error,invalid_peer_public_key}, - #ssh_msg_disconnect{ - code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, - description = "Peer ECDH public key is invalid", - language = ""} - }) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{ + code = ?SSH_DISCONNECT_KEY_EXCHANGE_FAILED, + description = "Peer ECDH public key is invalid"}, + invalid_peer_public_key) end. @@ -675,9 +671,10 @@ handle_new_keys(#ssh_msg_newkeys{}, Ssh0) -> {ok, Ssh} catch _C:_Error -> %% TODO: Throw earlier .... - throw(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = "Install alg failed", - language = "en"}) + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, + description = "Install alg failed" + }) end. %% select session id @@ -929,9 +926,9 @@ select_all(CL, SL) when length(CL) + length(SL) < ?MAX_NUM_ALGORITHMS -> lists:map(fun(ALG) -> list_to_atom(ALG) end, (CL -- A)); select_all(CL, SL) -> Err = lists:concat(["Received too many algorithms (",length(CL),"+",length(SL)," >= ",?MAX_NUM_ALGORITHMS,")."]), - throw(#ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, - description = Err, - language = ""}). + ssh_connection_handler:disconnect( + #ssh_msg_disconnect{code = ?SSH_DISCONNECT_PROTOCOL_ERROR, + description = Err}). select([], []) -> @@ -1042,7 +1039,7 @@ handle_packet_part(DecryptedPfx, EncryptedBuffer, TotalNeeded, {bad_mac, Ssh1}; true -> {Ssh, DecompressedPayload} = decompress(Ssh1, payload(DecryptedPacket)), - {decoded, DecompressedPayload, NextPacketBytes, Ssh} + {packet_decrypted, DecompressedPayload, NextPacketBytes, Ssh} end; aead -> PacketLenBin = DecryptedPfx, @@ -1052,7 +1049,7 @@ handle_packet_part(DecryptedPfx, EncryptedBuffer, TotalNeeded, {Ssh1, DecryptedSfx} -> DecryptedPacket = <<DecryptedPfx/binary, DecryptedSfx/binary>>, {Ssh, DecompressedPayload} = decompress(Ssh1, payload(DecryptedPacket)), - {decoded, DecompressedPayload, NextPacketBytes, Ssh} + {packet_decrypted, DecompressedPayload, NextPacketBytes, Ssh} end end. diff --git a/lib/ssh/src/sshc_sup.erl b/lib/ssh/src/sshc_sup.erl index 5667fd2aec..71b5c2c46a 100644 --- a/lib/ssh/src/sshc_sup.erl +++ b/lib/ssh/src/sshc_sup.erl @@ -64,7 +64,7 @@ child_spec(_) -> Name = undefined, % As simple_one_for_one is used. StartFunc = {ssh_connection_handler, start_link, []}, Restart = temporary, - Shutdown = infinity, + Shutdown = 4000, Modules = [ssh_connection_handler], - Type = supervisor, + Type = worker, {Name, StartFunc, Restart, Shutdown, Type, Modules}. diff --git a/lib/ssh/test/Makefile b/lib/ssh/test/Makefile index 4ecc662c13..6ce6d6f537 100644 --- a/lib/ssh/test/Makefile +++ b/lib/ssh/test/Makefile @@ -55,6 +55,7 @@ MODULES= \ ssh_relay HRL_FILES_NEEDED_IN_TEST= \ + $(ERL_TOP)/lib/ssh/test/ssh_test_lib.hrl \ $(ERL_TOP)/lib/ssh/src/ssh.hrl \ $(ERL_TOP)/lib/ssh/src/ssh_xfer.hrl diff --git a/lib/ssh/test/ssh_algorithms_SUITE.erl b/lib/ssh/test/ssh_algorithms_SUITE.erl index bdc980e65c..9910b8f1d7 100644 --- a/lib/ssh/test/ssh_algorithms_SUITE.erl +++ b/lib/ssh/test/ssh_algorithms_SUITE.erl @@ -192,7 +192,7 @@ simple_exec_groups_no_match_too_large(Config) -> %%-------------------------------------------------------------------- %% Testing all default groups -simple_exec_groups() -> [{timetrap,{seconds,180}}]. +simple_exec_groups() -> [{timetrap,{minutes,5}}]. simple_exec_groups(Config) -> Sizes = interpolate( public_key:dh_gex_group_sizes() ), @@ -226,28 +226,13 @@ sshc_simple_exec(Config) -> KnownHosts = filename:join(PrivDir, "known_hosts"), {Host,Port} = ?config(srvr_addr, Config), Cmd = lists:concat(["ssh -p ",Port, - " -C -o UserKnownHostsFile=",KnownHosts, + " -C", + " -o UserKnownHostsFile=",KnownHosts, + " -o StrictHostKeyChecking=no", " ",Host," 1+1."]), ct:log("~p",[Cmd]), - SshPort = open_port({spawn, Cmd}, [binary]), - Expect = <<"2\n">>, - rcv_expected(SshPort, Expect). - - -rcv_expected(SshPort, Expect) -> - receive - {SshPort, {data,Expect}} -> - ct:log("Got expected ~p from ~p",[Expect,SshPort]), - catch port_close(SshPort), - ok; - Other -> - ct:log("Got UNEXPECTED ~p",[Other]), - rcv_expected(SshPort, Expect) - - after ?TIMEOUT -> - catch port_close(SshPort), - ct:fail("Did not receive answer") - end. + OpenSsh = ssh_test_lib:open_port({spawn, Cmd}, [eof,exit_status]), + ssh_test_lib:rcv_expected({data,<<"2\n">>}, OpenSsh, ?TIMEOUT). %%-------------------------------------------------------------------- %% Connect to the ssh server of the OS @@ -361,13 +346,15 @@ get_atoms(L) -> %%% Test case related %%% start_std_daemon(Opts, Config) -> + ct:log("starting std_daemon",[]), {Pid, Host, Port} = ssh_test_lib:std_daemon(Config, Opts), ct:log("started ~p:~p ~p",[Host,Port,Opts]), [{srvr_pid,Pid},{srvr_addr,{Host,Port}} | Config]. -start_pubkey_daemon(Opts, Config) -> +start_pubkey_daemon(Opts0, Config) -> + Opts = [{auth_methods,"publickey"}|Opts0], {Pid, Host, Port} = ssh_test_lib:std_daemon1(Config, Opts), - ct:log("started1 ~p:~p ~p",[Host,Port,Opts]), + ct:log("started pubkey_daemon ~p:~p ~p",[Host,Port,Opts]), [{srvr_pid,Pid},{srvr_addr,{Host,Port}} | Config]. diff --git a/lib/ssh/test/ssh_benchmark_SUITE.erl b/lib/ssh/test/ssh_benchmark_SUITE.erl index 6e1d18cc95..1f11fee350 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE.erl +++ b/lib/ssh/test/ssh_benchmark_SUITE.erl @@ -333,52 +333,64 @@ find_time(accept_to_hello, L) -> [T0,T1] = find([fun(C=#call{mfa = {ssh_acceptor,handle_connection,5}}) -> C#call.t_call end, - fun(C=#call{mfa = {ssh_connection_handler,hello,_}, - args = [socket_control|_]}) -> - C#call.t_return - end + ?LINE, + fun(C=#call{mfa = {ssh_connection_handler,handle_event,5}, + args = [_, {version_exchange,_}, _, {hello,_}, _]}) -> + C#call.t_call + end, + ?LINE ], L, []), {accept_to_hello, now2micro_sec(now_diff(T1,T0)), microsec}; find_time(kex, L) -> - [T0,T1] = find([fun(C=#call{mfa = {ssh_connection_handler,hello,_}, - args = [socket_control|_]}) -> + [T0,T1] = find([fun(C=#call{mfa = {ssh_connection_handler,handle_event,5}, + args = [_, {version_exchange,_}, _, {hello,_}, _]}) -> C#call.t_call end, - ?send(#ssh_msg_newkeys{}) + ?LINE, + ?send(#ssh_msg_newkeys{}), + ?LINE ], L, []), {kex, now2micro_sec(now_diff(T1,T0)), microsec}; find_time(kex_to_auth, L) -> [T0,T1] = find([?send(#ssh_msg_newkeys{}), - ?recv(#ssh_msg_userauth_request{}) + ?LINE, + ?recv(#ssh_msg_userauth_request{}), + ?LINE ], L, []), {kex_to_auth, now2micro_sec(now_diff(T1,T0)), microsec}; find_time(auth, L) -> [T0,T1] = find([?recv(#ssh_msg_userauth_request{}), - ?send(#ssh_msg_userauth_success{}) + ?LINE, + ?send(#ssh_msg_userauth_success{}), + ?LINE ], L, []), {auth, now2micro_sec(now_diff(T1,T0)), microsec}; find_time(to_prompt, L) -> [T0,T1] = find([fun(C=#call{mfa = {ssh_acceptor,handle_connection,5}}) -> C#call.t_call end, - ?recv(#ssh_msg_channel_request{request_type="env"}) + ?LINE, + ?recv(#ssh_msg_channel_request{request_type="env"}), + ?LINE ], L, []), {to_prompt, now2micro_sec(now_diff(T1,T0)), microsec}; find_time(channel_open_close, L) -> [T0,T1] = find([?recv(#ssh_msg_channel_request{request_type="subsystem"}), - ?send(#ssh_msg_channel_close{}) + ?LINE, + ?send(#ssh_msg_channel_close{}), + ?LINE ], L, []), {channel_open_close, now2micro_sec(now_diff(T1,T0)), microsec}. -find([F|Fs], [C|Cs], Acc) when is_function(F,1) -> +find([F,Id|Fs], [C|Cs], Acc) when is_function(F,1) -> try F(C) of T -> find(Fs, Cs, [T|Acc]) catch - _:_ -> find([F|Fs], Cs, Acc) + _:_ -> find([F,Id|Fs], Cs, Acc) end; find([], _, Acc) -> lists:reverse(Acc). @@ -444,7 +456,7 @@ erlang_trace() -> 0 = erlang:trace(new, true, [call,timestamp,{tracer,TracerPid}]), [init_trace(MFA, tp(MFA)) || MFA <- [{ssh_acceptor,handle_connection,5}, - {ssh_connection_handler,hello,2}, +%% {ssh_connection_handler,hello,2}, {ssh_message,encode,1}, {ssh_message,decode,1}, {ssh_transport,select_algorithm,3}, @@ -454,6 +466,10 @@ erlang_trace() -> {ssh_message,decode,1}, {public_key,dh_gex_group,4} % To find dh_gex group size ]], + init_trace({ssh_connection_handler,handle_event,5}, + [{['_', {version_exchange,'_'}, '_', {hello,'_'}, '_'], + [], + [return_trace]}]), {ok, TracerPid}. tp({_M,_F,Arity}) -> diff --git a/lib/ssh/test/ssh_connection_SUITE.erl b/lib/ssh/test/ssh_connection_SUITE.erl index a5f424f863..0f757a0322 100644 --- a/lib/ssh/test/ssh_connection_SUITE.erl +++ b/lib/ssh/test/ssh_connection_SUITE.erl @@ -23,6 +23,7 @@ -include_lib("common_test/include/ct.hrl"). -include_lib("ssh/src/ssh_connect.hrl"). +-include("ssh_test_lib.hrl"). -compile(export_all). @@ -655,15 +656,21 @@ max_channels_option(Config) when is_list(Config) -> {user_interaction, true}, {user_dir, UserDir}]), + %% Allocate a number of ChannelId:s to play with. (This operation is not + %% counted by the max_channel option). {ok, ChannelId0} = ssh_connection:session_channel(ConnectionRef, infinity), {ok, ChannelId1} = ssh_connection:session_channel(ConnectionRef, infinity), {ok, ChannelId2} = ssh_connection:session_channel(ConnectionRef, infinity), {ok, ChannelId3} = ssh_connection:session_channel(ConnectionRef, infinity), {ok, ChannelId4} = ssh_connection:session_channel(ConnectionRef, infinity), {ok, ChannelId5} = ssh_connection:session_channel(ConnectionRef, infinity), - {ok, _ChannelId6} = ssh_connection:session_channel(ConnectionRef, infinity), + {ok, ChannelId6} = ssh_connection:session_channel(ConnectionRef, infinity), + {ok, _ChannelId7} = ssh_connection:session_channel(ConnectionRef, infinity), - %%%---- shell + %% Now start to open the channels (this is counted my max_channels) to check that + %% it gives a failure at right place + + %%%---- Channel 1(3): shell ok = ssh_connection:shell(ConnectionRef,ChannelId0), receive {ssh_cm,ConnectionRef, {data, ChannelId0, 0, <<"Eshell",_/binary>>}} -> @@ -672,10 +679,10 @@ max_channels_option(Config) when is_list(Config) -> ct:fail("CLI Timeout") end, - %%%---- subsystem "echo_n" + %%%---- Channel 2(3): subsystem "echo_n" success = ssh_connection:subsystem(ConnectionRef, ChannelId1, "echo_n", infinity), - %%%---- exec #1 + %%%---- Channel 3(3): exec. This closes itself. success = ssh_connection:exec(ConnectionRef, ChannelId2, "testing1.\n", infinity), receive {ssh_cm, ConnectionRef, {data, ChannelId2, 0, <<"testing1",_/binary>>}} -> @@ -684,13 +691,13 @@ max_channels_option(Config) when is_list(Config) -> ct:fail("Exec #1 Timeout") end, - %%%---- ptty - success = ssh_connection:ptty_alloc(ConnectionRef, ChannelId3, []), + %%%---- Channel 3(3): subsystem "echo_n" (Note that ChannelId2 should be closed now) + ?wait_match(success, ssh_connection:subsystem(ConnectionRef, ChannelId3, "echo_n", infinity)), - %%%---- exec #2 + %%%---- Channel 4(3) !: exec This should fail failure = ssh_connection:exec(ConnectionRef, ChannelId4, "testing2.\n", infinity), - %%%---- close the shell + %%%---- close the shell (Frees one channel) ok = ssh_connection:send(ConnectionRef, ChannelId0, "exit().\n", 5000), %%%---- wait for the subsystem to terminate @@ -703,14 +710,11 @@ max_channels_option(Config) when is_list(Config) -> ct:fail("exit Timeout",[]) end, - %%%---- exec #3 - success = ssh_connection:exec(ConnectionRef, ChannelId5, "testing3.\n", infinity), - receive - {ssh_cm, ConnectionRef, {data, ChannelId5, 0, <<"testing3",_/binary>>}} -> - ok - after 5000 -> - ct:fail("Exec #3 Timeout") - end, + %%---- Try that we can open one channel instead of the closed one + ?wait_match(success, ssh_connection:subsystem(ConnectionRef, ChannelId5, "echo_n", infinity)), + + %%---- But not a fourth one... + failure = ssh_connection:subsystem(ConnectionRef, ChannelId6, "echo_n", infinity), ssh:close(ConnectionRef), ssh:stop_daemon(Pid). diff --git a/lib/ssh/test/ssh_options_SUITE.erl b/lib/ssh/test/ssh_options_SUITE.erl index 1d14a16065..4ca6a473fa 100644 --- a/lib/ssh/test/ssh_options_SUITE.erl +++ b/lib/ssh/test/ssh_options_SUITE.erl @@ -51,9 +51,7 @@ ssh_connect_arg4_timeout/1, ssh_connect_negtimeout_parallel/1, ssh_connect_negtimeout_sequential/1, - ssh_connect_nonegtimeout_connected_parallel/0, ssh_connect_nonegtimeout_connected_parallel/1, - ssh_connect_nonegtimeout_connected_sequential/0, ssh_connect_nonegtimeout_connected_sequential/1, ssh_connect_timeout/1, connect/4, ssh_daemon_minimal_remote_max_packet_size_option/1, @@ -82,7 +80,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}, - {timetrap,{seconds,40}}]. + {timetrap,{seconds,30}}]. all() -> [connectfun_disconnectfun_server, @@ -493,7 +491,7 @@ ssh_msg_debug_fun_option_client(Config) -> {user_interaction, false}, {ssh_msg_debug_fun,DbgFun}]), %% Beware, implementation knowledge: - gen_fsm:send_all_state_event(ConnectionRef,{ssh_msg_debug,false,<<"Hello">>,<<>>}), + gen_statem:cast(ConnectionRef,{ssh_msg_debug,false,<<"Hello">>,<<>>}), receive {msg_dbg,X={ConnectionRef,false,<<"Hello">>,<<>>}} -> ct:log("Got expected dbg msg ~p",[X]), @@ -606,7 +604,7 @@ ssh_msg_debug_fun_option_server(Config) -> receive {connection_pid,Server} -> %% Beware, implementation knowledge: - gen_fsm:send_all_state_event(Server,{ssh_msg_debug,false,<<"Hello">>,<<>>}), + gen_statem:cast(Server,{ssh_msg_debug,false,<<"Hello">>,<<>>}), receive {msg_dbg,X={_,false,<<"Hello">>,<<>>}} -> ct:log("Got expected dbg msg ~p",[X]), @@ -982,16 +980,10 @@ ssh_connect_negtimeout(Config, Parallel) -> %%-------------------------------------------------------------------- %%% Test that ssh connection does not timeout if the connection is established (parallel) - -ssh_connect_nonegtimeout_connected_parallel() -> [{timetrap,{seconds,90}}]. - ssh_connect_nonegtimeout_connected_parallel(Config) -> ssh_connect_nonegtimeout_connected(Config, true). %%% Test that ssh connection does not timeout if the connection is established (non-parallel) - -ssh_connect_nonegtimeout_connected_sequential() -> [{timetrap,{seconds,90}}]. - ssh_connect_nonegtimeout_connected_sequential(Config) -> ssh_connect_nonegtimeout_connected(Config, false). @@ -1000,7 +992,7 @@ ssh_connect_nonegtimeout_connected(Config, Parallel) -> process_flag(trap_exit, true), SystemDir = filename:join(?config(priv_dir, Config), system), UserDir = ?config(priv_dir, Config), - NegTimeOut = 20000, % ms + NegTimeOut = 2000, % ms ct:log("Parallel: ~p",[Parallel]), {_Pid, _Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir},{user_dir, UserDir}, @@ -1131,21 +1123,7 @@ max_sessions(Config, ParallelLogin, Connect0) when is_function(Connect0,2) -> %% This is expected %% Now stop one connection and try to open one more ok = ssh:close(hd(Connections)), - receive after 250 -> ok end, % sleep so the supervisor has time to count down. Not nice... - try Connect(Host,Port) - of - _ConnectionRef1 -> - %% Step 3 ok: could set up one more connection after killing one - %% Thats good. - ssh:stop_daemon(Pid), - ok - catch - error:{badmatch,{error,"Connection closed"}} -> - %% Bad indeed. Could not set up one more connection even after killing - %% one existing. Very bad. - ssh:stop_daemon(Pid), - {fail,"Does not decrease # active sessions"} - end + try_to_connect(Connect, Host, Port, Pid) end catch error:{badmatch,{error,"Connection closed"}} -> @@ -1153,6 +1131,35 @@ max_sessions(Config, ParallelLogin, Connect0) when is_function(Connect0,2) -> {fail,"Too few connections accepted"} end. + +try_to_connect(Connect, Host, Port, Pid) -> + {ok,Tref} = timer:send_after(3000, timeout_no_connection), % give the supervisors some time... + try_to_connect(Connect, Host, Port, Pid, Tref, 1). % will take max 3300 ms after 11 tries + +try_to_connect(Connect, Host, Port, Pid, Tref, N) -> + try Connect(Host,Port) + of + _ConnectionRef1 -> + %% Step 3 ok: could set up one more connection after killing one + %% Thats good. + timer:cancel(Tref), + ssh:stop_daemon(Pid), + receive % flush. + timeout_no_connection -> ok + after 0 -> ok + end + catch + error:{badmatch,{error,"Connection closed"}} -> + %% Could not set up one more connection. Try again until timeout. + receive + timeout_no_connection -> + ssh:stop_daemon(Pid), + {fail,"Does not decrease # active sessions"} + after N*50 -> % retry after this time + try_to_connect(Connect, Host, Port, Pid, Tref, N+1) + end + end. + %%-------------------------------------------------------------------- %% Internal functions ------------------------------------------------ %%-------------------------------------------------------------------- diff --git a/lib/ssh/test/ssh_renegotiate_SUITE.erl b/lib/ssh/test/ssh_renegotiate_SUITE.erl index 90132becbd..f1a909cbd0 100644 --- a/lib/ssh/test/ssh_renegotiate_SUITE.erl +++ b/lib/ssh/test/ssh_renegotiate_SUITE.erl @@ -33,7 +33,6 @@ suite() -> [{ct_hooks,[ts_install_cth]}, {timetrap,{seconds,40}}]. - all() -> [{group,default_algs}, {group,aes_gcm} ]. @@ -238,7 +237,7 @@ renegotiate2(Config) -> %% get_kex_init - helper function to get key_exchange_init_msg get_kex_init(Conn) -> %% First, validate the key exchange is complete (StateName == connected) - {connected,S} = sys:get_state(Conn), + {{connected,_},S} = sys:get_state(Conn), %% Next, walk through the elements of the #state record looking %% for the #ssh_msg_kexinit record. This method is robust against %% changes to either record. The KEXINIT message contains a cookie diff --git a/lib/ssh/test/ssh_sftp_SUITE.erl b/lib/ssh/test/ssh_sftp_SUITE.erl index cd6c5f82b9..f6d7be41d6 100644 --- a/lib/ssh/test/ssh_sftp_SUITE.erl +++ b/lib/ssh/test/ssh_sftp_SUITE.erl @@ -38,7 +38,6 @@ suite() -> [{ct_hooks,[ts_install_cth]}, {timetrap,{seconds,40}}]. - all() -> [{group, not_unicode}, {group, unicode} @@ -301,9 +300,9 @@ end_per_testcase(_, Config) -> end_per_testcase(Config) -> {Sftp, Connection} = ?config(sftp, Config), - ssh_sftp:stop_channel(Sftp), + ok = ssh_sftp:stop_channel(Sftp), catch ssh_sftp:stop_channel(?config(channel_pid2, Config)), - ssh:close(Connection). + ok = ssh:close(Connection). %%-------------------------------------------------------------------- %% Test Cases -------------------------------------------------------- @@ -365,7 +364,7 @@ write_file(Config) when is_list(Config) -> {Sftp, _} = ?config(sftp, Config), Data = list_to_binary("Hej hopp!"), - ssh_sftp:write_file(Sftp, FileName, [Data]), + ok = ssh_sftp:write_file(Sftp, FileName, [Data]), {ok, Data} = file:read_file(FileName). %%-------------------------------------------------------------------- @@ -378,7 +377,7 @@ write_file_iolist(Config) when is_list(Config) -> Data = list_to_binary("Hej hopp!"), lists:foreach( fun(D) -> - ssh_sftp:write_file(Sftp, FileName, [D]), + ok = ssh_sftp:write_file(Sftp, FileName, [D]), Expected = if is_binary(D) -> D; is_list(D) -> list_to_binary(D) end, @@ -397,7 +396,7 @@ write_big_file(Config) when is_list(Config) -> {Sftp, _} = ?config(sftp, Config), Data = list_to_binary(lists:duplicate(750000,"a")), - ssh_sftp:write_file(Sftp, FileName, [Data]), + ok = ssh_sftp:write_file(Sftp, FileName, [Data]), {ok, Data} = file:read_file(FileName). %%-------------------------------------------------------------------- @@ -409,7 +408,7 @@ sftp_read_big_file(Config) when is_list(Config) -> Data = list_to_binary(lists:duplicate(750000,"a")), ct:log("Data size to write is ~p bytes",[size(Data)]), - ssh_sftp:write_file(Sftp, FileName, [Data]), + ok = ssh_sftp:write_file(Sftp, FileName, [Data]), {ok, Data} = ssh_sftp:read_file(Sftp, FileName). %%-------------------------------------------------------------------- @@ -425,7 +424,7 @@ remove_file(Config) when is_list(Config) -> ok = ssh_sftp:delete(Sftp, FileName), {ok, NewFiles} = ssh_sftp:list_dir(Sftp, PrivDir), false = lists:member(filename:basename(FileName), NewFiles), - {error, _} = ssh_sftp:delete(Sftp, FileName). + {error, no_such_file} = ssh_sftp:delete(Sftp, FileName). %%-------------------------------------------------------------------- rename_file() -> [{doc, "Test API function rename_file/2"}]. @@ -500,7 +499,7 @@ set_attributes(Config) when is_list(Config) -> io:put_chars(Fd,"foo"), ok = ssh_sftp:write_file_info(Sftp, FileName, #file_info{mode=8#400}), {error, eacces} = file:write_file(FileName, "hello again"), - ssh_sftp:write_file_info(Sftp, FileName, #file_info{mode=8#600}), + ok = ssh_sftp:write_file_info(Sftp, FileName, #file_info{mode=8#600}), ok = file:write_file(FileName, "hello again"). %%-------------------------------------------------------------------- @@ -549,7 +548,7 @@ position(Config) when is_list(Config) -> {Sftp, _} = ?config(sftp, Config), Data = list_to_binary("1234567890"), - ssh_sftp:write_file(Sftp, FileName, [Data]), + ok = ssh_sftp:write_file(Sftp, FileName, [Data]), {ok, Handle} = ssh_sftp:open(Sftp, FileName, [read]), {ok, 3} = ssh_sftp:position(Sftp, Handle, {bof, 3}), @@ -577,7 +576,7 @@ pos_read(Config) when is_list(Config) -> FileName = ?config(testfile, Config), {Sftp, _} = ?config(sftp, Config), Data = list_to_binary("Hej hopp!"), - ssh_sftp:write_file(Sftp, FileName, [Data]), + ok = ssh_sftp:write_file(Sftp, FileName, [Data]), {ok, Handle} = ssh_sftp:open(Sftp, FileName, [read]), {async, Ref} = ssh_sftp:apread(Sftp, Handle, {bof, 5}, 4), @@ -607,7 +606,7 @@ pos_write(Config) when is_list(Config) -> {ok, Handle} = ssh_sftp:open(Sftp, FileName, [write]), Data = list_to_binary("Bye,"), - ssh_sftp:write_file(Sftp, FileName, [Data]), + ok = ssh_sftp:write_file(Sftp, FileName, [Data]), NewData = list_to_binary(" see you tomorrow"), {async, Ref} = ssh_sftp:apwrite(Sftp, Handle, {bof, 4}, NewData), diff --git a/lib/ssh/test/ssh_sftpd_SUITE.erl b/lib/ssh/test/ssh_sftpd_SUITE.erl index fb1a9687af..9385bd127d 100644 --- a/lib/ssh/test/ssh_sftpd_SUITE.erl +++ b/lib/ssh/test/ssh_sftpd_SUITE.erl @@ -105,7 +105,6 @@ init_per_testcase(TestCase, Config) -> ClientUserDir = filename:join(PrivDir, nopubkey), SystemDir = filename:join(?config(priv_dir, Config), system), - Port = ssh_test_lib:inet_port(node()), Options = [{system_dir, SystemDir}, {user_dir, PrivDir}, {user_passwords,[{?USER, ?PASSWD}]}, @@ -113,11 +112,13 @@ init_per_testcase(TestCase, Config) -> {ok, Sftpd} = case TestCase of ver6_basic -> SubSystems = [ssh_sftpd:subsystem_spec([{sftpd_vsn, 6}])], - ssh:daemon(Port, [{subsystems, SubSystems}|Options]); + ssh:daemon(0, [{subsystems, SubSystems}|Options]); _ -> SubSystems = [ssh_sftpd:subsystem_spec([])], - ssh:daemon(Port, [{subsystems, SubSystems}|Options]) + ssh:daemon(0, [{subsystems, SubSystems}|Options]) end, + {ok,Dinf} = ssh:daemon_info(Sftpd), + Port = proplists:get_value(port, Dinf), Cm = ssh_test_lib:connect(Port, [{user_dir, ClientUserDir}, diff --git a/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl b/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl index 09bef87148..355ce6a8f5 100644 --- a/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl +++ b/lib/ssh/test/ssh_sftpd_erlclient_SUITE.erl @@ -39,7 +39,6 @@ suite() -> [{ct_hooks,[ts_install_cth]}, {timetrap,{seconds,40}}]. - all() -> [close_file, quit, diff --git a/lib/ssh/test/ssh_sup_SUITE.erl b/lib/ssh/test/ssh_sup_SUITE.erl index f800ea806d..f8929b30ff 100644 --- a/lib/ssh/test/ssh_sup_SUITE.erl +++ b/lib/ssh/test/ssh_sup_SUITE.erl @@ -22,21 +22,23 @@ -module(ssh_sup_SUITE). -include_lib("common_test/include/ct.hrl"). -include_lib("ssh/src/ssh.hrl"). +-include("ssh_test_lib.hrl"). %% Note: This directive should only be used in test suites. -compile(export_all). --define(WAIT_FOR_SHUTDOWN, 500). -define(USER, "Alladin"). -define(PASSWD, "Sesame"). +-define(WAIT_FOR_SHUTDOWN, 500). + %%-------------------------------------------------------------------- %% Common Test interface functions ----------------------------------- %%-------------------------------------------------------------------- suite() -> [{ct_hooks,[ts_install_cth]}, - {timetrap,{seconds,40}}]. + {timetrap,{seconds,100}}]. all() -> [default_tree, sshc_subtree, sshd_subtree, sshd_subtree_profile]. @@ -92,8 +94,8 @@ default_tree(Config) when is_list(Config) -> lists:keysearch(sshc_sup, 1, TopSupChildren), {value, {sshd_sup, _,supervisor,[sshd_sup]}} = lists:keysearch(sshd_sup, 1, TopSupChildren), - [] = supervisor:which_children(sshc_sup), - [] = supervisor:which_children(sshd_sup). + ?wait_match([], supervisor:which_children(sshc_sup)), + ?wait_match([], supervisor:which_children(sshd_sup)). sshc_subtree() -> [{doc, "Make sure the sshc subtree is correct"}]. @@ -101,24 +103,27 @@ sshc_subtree(Config) when is_list(Config) -> {_Pid, Host, Port} = ?config(server, Config), UserDir = ?config(userdir, Config), - [] = supervisor:which_children(sshc_sup), + ?wait_match([], supervisor:which_children(sshc_sup)), + {ok, Pid1} = ssh:connect(Host, Port, [{silently_accept_hosts, true}, {user_interaction, false}, {user, ?USER}, {password, ?PASSWD},{user_dir, UserDir}]), - [{_, _,supervisor,[ssh_connection_handler]}] = - supervisor:which_children(sshc_sup), + + ?wait_match([{_, _,worker,[ssh_connection_handler]}], + supervisor:which_children(sshc_sup)), + {ok, Pid2} = ssh:connect(Host, Port, [{silently_accept_hosts, true}, {user_interaction, false}, {user, ?USER}, {password, ?PASSWD}, {user_dir, UserDir}]), - [{_,_,supervisor,[ssh_connection_handler]}, - {_,_,supervisor,[ssh_connection_handler]}] = - supervisor:which_children(sshc_sup), + ?wait_match([{_,_,worker,[ssh_connection_handler]}, + {_,_,worker,[ssh_connection_handler]}], + supervisor:which_children(sshc_sup)), + ssh:close(Pid1), - [{_,_,supervisor,[ssh_connection_handler]}] = - supervisor:which_children(sshc_sup), + ?wait_match([{_,_,worker,[ssh_connection_handler]}], + supervisor:which_children(sshc_sup)), ssh:close(Pid2), - ct:sleep(?WAIT_FOR_SHUTDOWN), - [] = supervisor:which_children(sshc_sup). + ?wait_match([], supervisor:which_children(sshc_sup)). sshd_subtree() -> [{doc, "Make sure the sshd subtree is correct"}]. @@ -130,14 +135,16 @@ sshd_subtree(Config) when is_list(Config) -> {failfun, fun ssh_test_lib:failfun/2}, {user_passwords, [{?USER, ?PASSWD}]}]), - [{{server,ssh_system_sup, HostIP, Port, ?DEFAULT_PROFILE}, - Daemon, supervisor, - [ssh_system_sup]}] = - supervisor:which_children(sshd_sup), + + ?wait_match([{{server,ssh_system_sup, HostIP, Port, ?DEFAULT_PROFILE}, + Daemon, supervisor, + [ssh_system_sup]}], + supervisor:which_children(sshd_sup), + Daemon), check_sshd_system_tree(Daemon, Config), ssh:stop_daemon(HostIP, Port), ct:sleep(?WAIT_FOR_SHUTDOWN), - [] = supervisor:which_children(sshd_sup). + ?wait_match([], supervisor:which_children(sshd_sup)). sshd_subtree_profile() -> [{doc, "Make sure the sshd subtree using profile option is correct"}]. @@ -152,14 +159,15 @@ sshd_subtree_profile(Config) when is_list(Config) -> {user_passwords, [{?USER, ?PASSWD}]}, {profile, Profile}]), - [{{server,ssh_system_sup, HostIP,Port,Profile}, - Daemon, supervisor, - [ssh_system_sup]}] = - supervisor:which_children(sshd_sup), + ?wait_match([{{server,ssh_system_sup, HostIP,Port,Profile}, + Daemon, supervisor, + [ssh_system_sup]}], + supervisor:which_children(sshd_sup), + Daemon), check_sshd_system_tree(Daemon, Config), ssh:stop_daemon(HostIP, Port, Profile), ct:sleep(?WAIT_FOR_SHUTDOWN), - [] = supervisor:which_children(sshd_sup). + ?wait_match([], supervisor:which_children(sshd_sup)). check_sshd_system_tree(Daemon, Config) -> @@ -170,28 +178,31 @@ check_sshd_system_tree(Daemon, Config) -> {user_interaction, false}, {user, ?USER}, {password, ?PASSWD},{user_dir, UserDir}]), - [{_,SubSysSup, supervisor,[ssh_subsystem_sup]}, - {{ssh_acceptor_sup,_,_,_}, AccSup, supervisor,[ssh_acceptor_sup]}] - = supervisor:which_children(Daemon), + ?wait_match([{_,SubSysSup, supervisor,[ssh_subsystem_sup]}, + {{ssh_acceptor_sup,_,_,_}, AccSup, supervisor,[ssh_acceptor_sup]}], + supervisor:which_children(Daemon), + [SubSysSup,AccSup]), - [{{server,ssh_connection_sup, _,_}, - ConnectionSup, supervisor, - [ssh_connection_sup]}, - {{server,ssh_channel_sup,_ ,_}, - ChannelSup,supervisor, - [ssh_channel_sup]}] = supervisor:which_children(SubSysSup), + ?wait_match([{{server,ssh_connection_sup, _,_}, + ConnectionSup, supervisor, + [ssh_connection_sup]}, + {{server,ssh_channel_sup,_ ,_}, + ChannelSup,supervisor, + [ssh_channel_sup]}], + supervisor:which_children(SubSysSup), + [ConnectionSup,ChannelSup]), - [{{ssh_acceptor_sup,_,_,_},_,worker,[ssh_acceptor]}] = - supervisor:which_children(AccSup), + ?wait_match([{{ssh_acceptor_sup,_,_,_},_,worker,[ssh_acceptor]}], + supervisor:which_children(AccSup)), - [{_, _, worker,[ssh_connection_handler]}] = - supervisor:which_children(ConnectionSup), + ?wait_match([{_, _, worker,[ssh_connection_handler]}], + supervisor:which_children(ConnectionSup)), - [] = supervisor:which_children(ChannelSup), + ?wait_match([], supervisor:which_children(ChannelSup)), ssh_sftp:start_channel(Client), - [{_, _,worker,[ssh_channel]}] = - supervisor:which_children(ChannelSup), + ?wait_match([{_, _,worker,[ssh_channel]}], + supervisor:which_children(ChannelSup)), ssh:close(Client). diff --git a/lib/ssh/test/ssh_test_cli.erl b/lib/ssh/test/ssh_test_cli.erl index 697ddb730d..f96b9967d2 100644 --- a/lib/ssh/test/ssh_test_cli.erl +++ b/lib/ssh/test/ssh_test_cli.erl @@ -75,10 +75,11 @@ terminate(_Why, _S) -> run_portprog(User, cli, TmpDir) -> Pty_bin = os:find_executable("cat"), - open_port({spawn_executable, Pty_bin}, - [stream, {cd, TmpDir}, {env, [{"USER", User}]}, - {args, []}, binary, - exit_status, use_stdio, stderr_to_stdout]). + ssh_test_lib:open_port({spawn_executable, Pty_bin}, + [stream, + {cd, TmpDir}, + {env, [{"USER", User}]}, + {args, []}]). get_ssh_user(Ref) -> [{user, User}] = ssh:connection_info(Ref, [user]), diff --git a/lib/ssh/test/ssh_test_lib.erl b/lib/ssh/test/ssh_test_lib.erl index 4db7d09ccd..c6541461a1 100644 --- a/lib/ssh/test/ssh_test_lib.erl +++ b/lib/ssh/test/ssh_test_lib.erl @@ -32,15 +32,8 @@ -define(TIMEOUT, 50000). -connect(Options) -> - connect(hostname(), inet_port(), Options). - connect(Port, Options) when is_integer(Port) -> - connect(hostname(), Port, Options); -connect(any, Options) -> - connect(hostname(), inet_port(), Options); -connect(Host, Options) -> - connect(Host, inet_port(), Options). + connect(hostname(), Port, Options). connect(any, Port, Options) -> connect(hostname(), Port, Options); @@ -49,23 +42,33 @@ connect(Host, Port, Options) -> ConnectionRef. daemon(Options) -> - daemon(any, inet_port(), Options). + daemon(any, 0, Options). daemon(Port, Options) when is_integer(Port) -> daemon(any, Port, Options); daemon(Host, Options) -> - daemon(Host, inet_port(), Options). + daemon(Host, 0, Options). + daemon(Host, Port, Options) -> + ct:log("~p:~p Calling ssh:daemon(~p, ~p, ~p)",[?MODULE,?LINE,Host,Port,Options]), case ssh:daemon(Host, Port, Options) of {ok, Pid} when Host == any -> - {Pid, hostname(), Port}; + ct:log("ssh:daemon ok (1)",[]), + {Pid, hostname(), daemon_port(Port,Pid)}; {ok, Pid} -> - {Pid, Host, Port}; + ct:log("ssh:daemon ok (2)",[]), + {Pid, Host, daemon_port(Port,Pid)}; Error -> + ct:log("ssh:daemon error ~p",[Error]), Error end. +daemon_port(0, Pid) -> {ok,Dinf} = ssh:daemon_info(Pid), + proplists:get_value(port, Dinf); +daemon_port(Port, _) -> Port. + + std_daemon(Config, ExtraOpts) -> PrivDir = ?config(priv_dir, Config), @@ -201,6 +204,35 @@ reply(TestCase, Result) -> %%ct:log("reply ~p sending ~p ! ~p",[self(), TestCase, Result]), TestCase ! Result. + + +rcv_expected(Expect, SshPort, Timeout) -> + receive + {SshPort, Expect} -> + ct:log("Got expected ~p from ~p",[Expect,SshPort]), + catch port_close(SshPort), + rcv_lingering(50); + Other -> + ct:log("Got UNEXPECTED ~p~nExpect ~p",[Other, {SshPort,Expect}]), + rcv_expected(Expect, SshPort, Timeout) + + after Timeout -> + catch port_close(SshPort), + ct:fail("Did not receive answer") + end. + +rcv_lingering(Timeout) -> + receive + Msg -> + ct:log("Got LINGERING ~p",[Msg]), + rcv_lingering(Timeout) + + after Timeout -> + ct:log("No more lingering messages",[]), + ok + end. + + receive_exec_result(Msg) -> ct:log("Expect data! ~p", [Msg]), receive @@ -470,8 +502,9 @@ openssh_supports(ClientOrServer, Tag, Alg) when ClientOrServer == sshc ; %% Check if we have a "newer" ssh client that supports these test cases ssh_client_supports_Q() -> - ErlPort = open_port({spawn, "ssh -Q cipher"}, [exit_status, stderr_to_stdout]), - 0 == check_ssh_client_support2(ErlPort). + 0 == check_ssh_client_support2( + ?MODULE:open_port({spawn, "ssh -Q cipher"}) + ). check_ssh_client_support2(P) -> receive @@ -690,3 +723,16 @@ has_inet6_address() -> catch throw:6 -> true end. + +%%%---------------------------------------------------------------- +open_port(Arg1) -> + ?MODULE:open_port(Arg1, []). + +open_port(Arg1, ExtraOpts) -> + erlang:open_port(Arg1, + [binary, + stderr_to_stdout, + exit_status, + use_stdio, + overlapped_io, hide %only affects windows + | ExtraOpts]). diff --git a/lib/ssh/test/ssh_test_lib.hrl b/lib/ssh/test/ssh_test_lib.hrl new file mode 100644 index 0000000000..7cb7edeaa8 --- /dev/null +++ b/lib/ssh/test/ssh_test_lib.hrl @@ -0,0 +1,27 @@ +%%------------------------------------------------------------------------- +%% Help macro +%%------------------------------------------------------------------------- +-define(wait_match(Pattern, FunctionCall, Bind, Timeout, Ntries), + Bind = + (fun() -> + F = fun(N, F1) -> + case FunctionCall of + Pattern -> Bind; + _ when N>0 -> + ct:pal("Must sleep ~p ms at ~p:~p",[Timeout,?MODULE,?LINE]), + timer:sleep(Timeout), + F1(N-1, F1); + Other -> + ct:fail("Unexpected ~p:~p ~p",[?MODULE,?LINE,Other]) + end + end, + F(Ntries, F) + end)() + ). + +-define(wait_match(Pattern, FunctionCall, Timeout, Ntries), ?wait_match(Pattern, FunctionCall, ok, Timeout, Ntries)). + +-define(wait_match(Pattern, FunctionCall, Bind), ?wait_match(Pattern, FunctionCall, Bind, 500, 10) ). + +-define(wait_match(Pattern, FunctionCall), ?wait_match(Pattern, FunctionCall, ok) ). + diff --git a/lib/ssh/test/ssh_to_openssh_SUITE.erl b/lib/ssh/test/ssh_to_openssh_SUITE.erl index 5b65edc32f..2be75fd7f3 100644 --- a/lib/ssh/test/ssh_to_openssh_SUITE.erl +++ b/lib/ssh/test/ssh_to_openssh_SUITE.erl @@ -34,7 +34,7 @@ %%-------------------------------------------------------------------- suite() -> - [{timetrap,{seconds,40}}]. + [{timetrap,{seconds,20}}]. all() -> case os:find_executable("ssh") of @@ -50,13 +50,15 @@ groups() -> [{erlang_client, [], [erlang_shell_client_openssh_server, erlang_client_openssh_server_exec_compressed, erlang_client_openssh_server_setenv, - erlang_client_openssh_server_publickey_rsa, erlang_client_openssh_server_publickey_dsa, + erlang_client_openssh_server_publickey_rsa, erlang_client_openssh_server_password, erlang_client_openssh_server_kexs, erlang_client_openssh_server_nonexistent_subsystem ]}, - {erlang_server, [], [erlang_server_openssh_client_public_key_dsa]} + {erlang_server, [], [erlang_server_openssh_client_public_key_dsa, + erlang_server_openssh_client_public_key_rsa + ]} ]. init_per_suite(Config) -> @@ -74,6 +76,7 @@ init_per_group(erlang_server, Config) -> DataDir = ?config(data_dir, Config), UserDir = ?config(priv_dir, Config), ssh_test_lib:setup_dsa_known_host(DataDir, UserDir), + ssh_test_lib:setup_rsa_known_host(DataDir, UserDir), Config; init_per_group(erlang_client, Config) -> CommonAlgs = ssh_test_lib:algo_intersection( @@ -86,6 +89,7 @@ init_per_group(_, Config) -> end_per_group(erlang_server, Config) -> UserDir = ?config(priv_dir, Config), ssh_test_lib:clean_dsa(UserDir), + ssh_test_lib:clean_rsa(UserDir), Config; end_per_group(_, Config) -> Config. @@ -93,6 +97,8 @@ end_per_group(_, Config) -> init_per_testcase(erlang_server_openssh_client_public_key_dsa, Config) -> chk_key(sshc, 'ssh-dss', ".ssh/id_dsa", Config); +init_per_testcase(erlang_server_openssh_client_public_key_rsa, Config) -> + chk_key(sshc, 'ssh-rsa', ".ssh/id_rsa", Config); init_per_testcase(erlang_client_openssh_server_publickey_dsa, Config) -> chk_key(sshd, 'ssh-dss', ".ssh/id_dsa", Config); init_per_testcase(_TestCase, Config) -> @@ -347,14 +353,24 @@ erlang_client_openssh_server_publickey_dsa(Config) when is_list(Config) -> %%-------------------------------------------------------------------- erlang_server_openssh_client_public_key_dsa() -> - [{doc, "Validate using dsa publickey."}]. + [{timetrap, {seconds,(?TIMEOUT div 1000)+10}}, + {doc, "Validate using dsa publickey."}]. erlang_server_openssh_client_public_key_dsa(Config) when is_list(Config) -> + erlang_server_openssh_client_public_key_X(Config, ssh_dsa). + +erlang_server_openssh_client_public_key_rsa() -> + [{timetrap, {seconds,(?TIMEOUT div 1000)+10}}, + {doc, "Validate using rsa publickey."}]. +erlang_server_openssh_client_public_key_rsa(Config) when is_list(Config) -> + erlang_server_openssh_client_public_key_X(Config, ssh_rsa). + + +erlang_server_openssh_client_public_key_X(Config, PubKeyAlg) -> SystemDir = ?config(data_dir, Config), PrivDir = ?config(priv_dir, Config), KnownHosts = filename:join(PrivDir, "known_hosts"), - {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, - {public_key_alg, ssh_dsa}, + {public_key_alg, PubKeyAlg}, {failfun, fun ssh_test_lib:failfun/2}]), ct:sleep(500), @@ -362,18 +378,8 @@ erlang_server_openssh_client_public_key_dsa(Config) when is_list(Config) -> Cmd = "ssh -p " ++ integer_to_list(Port) ++ " -o UserKnownHostsFile=" ++ KnownHosts ++ " " ++ Host ++ " 1+1.", - SshPort = open_port({spawn, Cmd}, [binary, stderr_to_stdout]), - - receive - {SshPort,{data, <<"2\n">>}} -> - ok - after ?TIMEOUT -> - receive - X -> ct:fail("Received: ~p",[X]) - after 0 -> - ct:fail("Did not receive answer") - end - end, + OpenSsh = ssh_test_lib:open_port({spawn, Cmd}), + ssh_test_lib:rcv_expected({data,<<"2\n">>}, OpenSsh, ?TIMEOUT), ssh:stop_daemon(Pid). %%-------------------------------------------------------------------- diff --git a/lib/ssh/test/ssh_to_openssh_SUITE_data/ssh_host_rsa_key b/lib/ssh/test/ssh_to_openssh_SUITE_data/ssh_host_rsa_key new file mode 100644 index 0000000000..79968bdd7d --- /dev/null +++ b/lib/ssh/test/ssh_to_openssh_SUITE_data/ssh_host_rsa_key @@ -0,0 +1,16 @@ +-----BEGIN RSA PRIVATE KEY----- +MIICXQIBAAKBgQDCZX+4FBDwZIh9y/Uxee1VJnEXlowpz2yDKwj8semM4q843337 +zbNfxHmladB1lpz2NqyxI175xMIJuDxogyZdsOxGnFAzAnthR4dqL/RWRWzjaxSB +6IAO9SPYVVlrpZ+1hsjLW79fwXK/yc8VdhRuWTeQiRgYY2ek8+OKbOqz4QIDAQAB +AoGANmvJzJO5hkLuvyDZHKfAnGTtpifcR1wtSa9DjdKUyn8vhKF0mIimnbnYQEmW +NUUb3gXCZLi9PvkpRSVRrASDOZwcjoU/Kvww163vBUVb2cOZfFhyn6o2Sk88Tt++ +udH3hdjpf9i7jTtUkUe+QYPsia+wgvvrmn4QrahLAH86+kECQQDx5gFeXTME3cnW +WMpFz3PPumduzjqgqMMWEccX4FtQkMX/gyGa5UC7OHFyh0N/gSWvPbRHa8A6YgIt +n8DO+fh5AkEAzbqX4DOn8NY6xJIi42q7l/2jIA0RkB6P7YugW5NblhqBZ0XDnpA5 +sMt+rz+K07u9XZtxgh1xi7mNfwY6lEAMqQJBAJBEauCKmRj35Z6OyeQku59SPsnY ++SJEREVvSNw2lH9SOKQQ4wPsYlTGbvKtNVZgAcen91L5MmYfeckYE/fdIZECQQCt +64zxsTnM1I8iFxj/gP/OYlJBikrKt8udWmjaghzvLMEw+T2DExJyb9ZNeT53+UMB +m6O+B/4xzU/djvp+0hbhAkAemIt+rA5kTmYlFndhpvzkSSM8a2EXsO4XIPgGWCTT +tQKS/tTly0ADMjN/TVy11+9d6zcqadNVuHXHGtR4W0GR +-----END RSA PRIVATE KEY----- + diff --git a/lib/ssh/test/ssh_to_openssh_SUITE_data/ssh_host_rsa_key.pub b/lib/ssh/test/ssh_to_openssh_SUITE_data/ssh_host_rsa_key.pub new file mode 100644 index 0000000000..75d2025c71 --- /dev/null +++ b/lib/ssh/test/ssh_to_openssh_SUITE_data/ssh_host_rsa_key.pub @@ -0,0 +1,5 @@ +---- BEGIN SSH2 PUBLIC KEY ---- +AAAAB3NzaC1yc2EAAAADAQABAAAAgQDCZX+4FBDwZIh9y/Uxee1VJnEXlowpz2yDKwj8 +semM4q843337zbNfxHmladB1lpz2NqyxI175xMIJuDxogyZdsOxGnFAzAnthR4dqL/RW +RWzjaxSB6IAO9SPYVVlrpZ+1hsjLW79fwXK/yc8VdhRuWTeQiRgYY2ek8+OKbOqz4Q== +---- END SSH2 PUBLIC KEY ---- diff --git a/lib/ssh/test/ssh_trpt_test_lib.erl b/lib/ssh/test/ssh_trpt_test_lib.erl index 4269529ae8..e34071af99 100644 --- a/lib/ssh/test/ssh_trpt_test_lib.erl +++ b/lib/ssh/test/ssh_trpt_test_lib.erl @@ -294,12 +294,11 @@ instantiate(X, _S) -> %%%================================================================ %%% init_ssh(Role, Socket, Options0) -> - Options = [{user_interaction,false} + Options = [{user_interaction, false}, + {vsn, {2,0}}, + {id_string, "ErlangTestLib"} | Options0], - ssh_connection_handler:init_ssh(Role, - {2,0}, - lists:concat(["SSH-2.0-ErlangTestLib ",Role]), - Options, Socket). + ssh_connection_handler:init_ssh_record(Role, Socket, Options). mangle_opts(Options) -> SysOpts = [{reuseaddr, true}, diff --git a/lib/ssh/vsn.mk b/lib/ssh/vsn.mk index 41b42d454b..b165928877 100644 --- a/lib/ssh/vsn.mk +++ b/lib/ssh/vsn.mk @@ -1,5 +1,5 @@ #-*-makefile-*- ; force emacs to enter makefile-mode -SSH_VSN = 4.2.2 +SSH_VSN = 4.3 APP_VSN = "ssh-$(SSH_VSN)" diff --git a/lib/ssl/src/ssl_cipher.erl b/lib/ssl/src/ssl_cipher.erl index 544d9b41cd..dc0a0c2cc4 100644 --- a/lib/ssl/src/ssl_cipher.erl +++ b/lib/ssl/src/ssl_cipher.erl @@ -992,21 +992,21 @@ suite({ecdh_rsa, aes_256_cbc, sha384, sha384}) -> %% RFC 5288 AES-GCM Cipher Suites suite({rsa, aes_128_gcm, null, sha256}) -> ?TLS_RSA_WITH_AES_128_GCM_SHA256; -suite({rsa, aes_256_gcm, null}) -> +suite({rsa, aes_256_gcm, null, sha384}) -> ?TLS_RSA_WITH_AES_256_GCM_SHA384; -suite({dhe_rsa, aes_128_gcm, null, sha384}) -> +suite({dhe_rsa, aes_128_gcm, null, sha256}) -> ?TLS_DHE_RSA_WITH_AES_128_GCM_SHA256; -suite({dhe_rsa, aes_256_gcm, null, sha256}) -> +suite({dhe_rsa, aes_256_gcm, null, sha384}) -> ?TLS_DHE_RSA_WITH_AES_256_GCM_SHA384; -suite({dh_rsa, aes_128_gcm, null, sha384}) -> +suite({dh_rsa, aes_128_gcm, null, sha256}) -> ?TLS_DH_RSA_WITH_AES_128_GCM_SHA256; -suite({dh_rsa, aes_256_gcm, null, sha256}) -> +suite({dh_rsa, aes_256_gcm, null, sha384}) -> ?TLS_DH_RSA_WITH_AES_256_GCM_SHA384; -suite({dhe_dss, aes_128_gcm, null, sha384}) -> +suite({dhe_dss, aes_128_gcm, null, sha256}) -> ?TLS_DHE_DSS_WITH_AES_128_GCM_SHA256; -suite({dhe_dss, aes_256_gcm, null, sha256}) -> +suite({dhe_dss, aes_256_gcm, null, sha384}) -> ?TLS_DHE_DSS_WITH_AES_256_GCM_SHA384; -suite({dh_dss, aes_128_gcm, null, sha384}) -> +suite({dh_dss, aes_128_gcm, null, sha256}) -> ?TLS_DH_DSS_WITH_AES_128_GCM_SHA256; suite({dh_dss, aes_256_gcm, null, sha384}) -> ?TLS_DH_DSS_WITH_AES_256_GCM_SHA384; diff --git a/lib/ssl/src/ssl_manager.erl b/lib/ssl/src/ssl_manager.erl index 2349158b11..60b4fbe995 100644 --- a/lib/ssl/src/ssl_manager.erl +++ b/lib/ssl/src/ssl_manager.erl @@ -610,8 +610,8 @@ server_register_session(Port, Session, #state{session_cache_server_max = Max, do_register_session(Key, Session, Max, Pid, Cache, CacheCb) -> try CacheCb:size(Cache) of - N when N > Max -> - invalidate_session_cache(Pid, CacheCb, Cache); + Max -> + invalidate_session_cache(Pid, CacheCb, Cache); _ -> CacheCb:update(Cache, Key, Session), Pid diff --git a/lib/ssl/src/tls_handshake.erl b/lib/ssl/src/tls_handshake.erl index ef718c13df..102dbba198 100644 --- a/lib/ssl/src/tls_handshake.erl +++ b/lib/ssl/src/tls_handshake.erl @@ -278,10 +278,11 @@ handle_server_hello_extensions(Version, SessionId, Random, CipherSuite, {Version, SessionId, ConnectionStates, ProtoExt, Protocol} end. -available_signature_algs(undefined, SupportedHashSigns, _, {Major, Minor}) when (Major < 3) andalso (Minor < 3) -> +available_signature_algs(undefined, SupportedHashSigns, _, {Major, Minor}) when + (Major >= 3) andalso (Minor >= 3) -> SupportedHashSigns; available_signature_algs(#hash_sign_algos{hash_sign_algos = ClientHashSigns}, SupportedHashSigns, - _, {Major, Minor}) when (Major < 3) andalso (Minor < 3) -> + _, {Major, Minor}) when (Major >= 3) andalso (Minor >= 3) -> ordsets:intersection(ClientHashSigns, SupportedHashSigns); available_signature_algs(_, _, _, _) -> undefined. diff --git a/lib/ssl/test/ssl_basic_SUITE.erl b/lib/ssl/test/ssl_basic_SUITE.erl index 0c3c7aa39b..3fea38078f 100644 --- a/lib/ssl/test/ssl_basic_SUITE.erl +++ b/lib/ssl/test/ssl_basic_SUITE.erl @@ -88,7 +88,8 @@ basic_tests() -> connect_dist, clear_pem_cache, defaults, - fallback + fallback, + cipher_format ]. options_tests() -> @@ -764,6 +765,14 @@ fallback(Config) when is_list(Config) -> Client, {error,{tls_alert,"inappropriate fallback"}}). %%-------------------------------------------------------------------- +cipher_format() -> + [{doc, "Test that cipher conversion from tuples to binarys works"}]. +cipher_format(Config) when is_list(Config) -> + {ok, Socket} = ssl:listen(0, [{ciphers, ssl:cipher_suites()}]), + ssl:close(Socket). + +%%-------------------------------------------------------------------- + peername() -> [{doc,"Test API function peername/1"}]. diff --git a/lib/stdlib/src/proc_lib.erl b/lib/stdlib/src/proc_lib.erl index 3f79ed0f87..fdc2ae4070 100644 --- a/lib/stdlib/src/proc_lib.erl +++ b/lib/stdlib/src/proc_lib.erl @@ -48,7 +48,9 @@ | {'priority', priority_level()} | {'min_heap_size', non_neg_integer()} | {'min_bin_vheap_size', non_neg_integer()} - | {'fullsweep_after', non_neg_integer()}. + | {'fullsweep_after', non_neg_integer()} + | {'message_queue_data', + 'off_heap' | 'on_heap' | 'mixed' }. -type dict_or_pid() :: pid() | (ProcInfo :: [_]) diff --git a/lib/tools/src/fprof.erl b/lib/tools/src/fprof.erl index f9da748fef..b21eedc625 100644 --- a/lib/tools/src/fprof.erl +++ b/lib/tools/src/fprof.erl @@ -1629,15 +1629,24 @@ trace_handler({trace_ts, Pid, in, {_M, _F, Args} = MFArgs, TS} = Trace, TS; %% %% gc_start -trace_handler({trace_ts, Pid, gc_start, _Func, TS} = Trace, - Table, _, Dump) -> +trace_handler({trace_ts, Pid, gc_minor_start, _Func, TS} = Trace, Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_gc_start(Table, Pid, TS), + TS; + +trace_handler({trace_ts, Pid, gc_major_start, _Func, TS} = Trace, Table, _, Dump) -> dump_stack(Dump, get(Pid), Trace), trace_gc_start(Table, Pid, TS), TS; + %% %% gc_end -trace_handler({trace_ts, Pid, gc_end, _Func, TS} = Trace, - Table, _, Dump) -> +trace_handler({trace_ts, Pid, gc_minor_end, _Func, TS} = Trace, Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_gc_end(Table, Pid, TS), + TS; + +trace_handler({trace_ts, Pid, gc_major_end, _Func, TS} = Trace, Table, _, Dump) -> dump_stack(Dump, get(Pid), Trace), trace_gc_end(Table, Pid, TS), TS; diff --git a/lib/tools/test/fprof_SUITE.erl b/lib/tools/test/fprof_SUITE.erl index e18d384b52..affb45b7a6 100644 --- a/lib/tools/test/fprof_SUITE.erl +++ b/lib/tools/test/fprof_SUITE.erl @@ -949,8 +949,8 @@ handle_trace({trace_ts,Pid,return_to,MFA,TS},P) -> end, put({Pid,last_ts},TS), P; -handle_trace({trace_ts,Pid,gc_start,_,TS},P) -> - ?dbg("~p",[{{gc_start,Pid},get(Pid)}]), +handle_trace({trace_ts,Pid,gc_minor_start,_,TS},P) -> + ?dbg("~p",[{{gc_minor_start,Pid},get(Pid)}]), case get(Pid) of [suspend|_] = Stack -> T = ts_sub(TS,get({Pid,last_ts})), @@ -970,8 +970,40 @@ handle_trace({trace_ts,Pid,gc_start,_,TS},P) -> end, put({Pid,last_ts},TS), P; -handle_trace({trace_ts,Pid,gc_end,_,TS},P) -> - ?dbg("~p",[{{gc_end,Pid},get(Pid)}]), +handle_trace({trace_ts,Pid,gc_major_start,_,TS},P) -> + ?dbg("~p",[{{gc_minor_start,Pid},get(Pid)}]), + case get(Pid) of + [suspend|_] = Stack -> + T = ts_sub(TS,get({Pid,last_ts})), + insert(Pid,garbage_collect), + update_acc(Pid,Stack,T), + put(Pid,[garbage_collect|Stack]); + [CallingMFA|_] = Stack -> + T = ts_sub(TS,get({Pid,last_ts})), + insert(Pid,garbage_collect), + update_own(Pid,CallingMFA,T), + update_acc(Pid,Stack,T), + put(Pid,[garbage_collect|Stack]); + undefined -> + put(first_ts,TS), + put(Pid,[garbage_collect]), + insert(Pid,garbage_collect) + end, + put({Pid,last_ts},TS), + P; +handle_trace({trace_ts,Pid,gc_minor_end,_,TS},P) -> + ?dbg("~p",[{{gc_minor_end,Pid},get(Pid)}]), + T = ts_sub(TS,get({Pid,last_ts})), + case get(Pid) of + [garbage_collect|RestOfStack] = Stack -> + update_own(Pid,garbage_collect,T), + update_acc(Pid,Stack,T), + put(Pid,RestOfStack) + end, + put({Pid,last_ts},TS), + P; +handle_trace({trace_ts,Pid,gc_major_end,_,TS},P) -> + ?dbg("~p",[{{gc_major_end,Pid},get(Pid)}]), T = ts_sub(TS,get({Pid,last_ts})), case get(Pid) of [garbage_collect|RestOfStack] = Stack -> |