diff options
Diffstat (limited to 'lib')
693 files changed, 33271 insertions, 15936 deletions
diff --git a/lib/asn1/doc/src/notes.xml b/lib/asn1/doc/src/notes.xml index ae6660c143..1abe983221 100644 --- a/lib/asn1/doc/src/notes.xml +++ b/lib/asn1/doc/src/notes.xml @@ -32,6 +32,31 @@ <p>This document describes the changes made to the asn1 application.</p> +<section><title>Asn1 5.0.4</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + There was a issue with BER encoding and the + <c>undec_rest</c> option in generated decoders. An + exception could be thrown instead of returning an error + tuple.</p> + <p> + Own Id: OTP-14786 Aux Id: ERL-518 </p> + </item> + <item> + <p> + The asn1ct:test functions crashed on decoders generated + with options <c>no_ok_wrapper</c>, <c>undec_rest</c>.</p> + <p> + Own Id: OTP-14787 Aux Id: ERL-518 </p> + </item> + </list> + </section> + +</section> + <section><title>Asn1 5.0.3</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/asn1/src/asn1ct.erl b/lib/asn1/src/asn1ct.erl index f36d71a601..81a2735a0d 100644 --- a/lib/asn1/src/asn1ct.erl +++ b/lib/asn1/src/asn1ct.erl @@ -1335,25 +1335,39 @@ test_value(Module, Type, Value) -> in_process(fun() -> case catch Module:encode(Type, Value) of {ok, Bytes} -> - NewBytes = prepare_bytes(Bytes), - case Module:decode(Type, NewBytes) of - {ok, Value} -> - {ok, {Module, Type, Value}}; - {ok, Res} -> - {error, {asn1, - {encode_decode_mismatch, - {{Module, Type, Value}, Res}}}}; - Error -> - {error, {asn1, - {{decode, - {Module, Type, Value}, Error}}}} - end; + test_value_decode(Module, Type, Value, Bytes); + Bytes when is_binary(Bytes) -> + test_value_decode(Module, Type, Value, Bytes); Error -> {error, {asn1, {encode, {{Module, Type, Value}, Error}}}} end end). + +test_value_decode(Module, Type, Value, Bytes) -> + NewBytes = prepare_bytes(Bytes), + case Module:decode(Type, NewBytes) of + {ok,Value} -> {ok, {Module,Type,Value}}; + {ok,Value,<<>>} -> {ok, {Module,Type,Value}}; + Value -> {ok, {Module,Type,Value}}; + {Value,<<>>} -> {ok, {Module,Type,Value}}; + + %% Errors: + {ok, Res} -> + {error, {asn1, + {encode_decode_mismatch, + {{Module, Type, Value}, Res}}}}; + {ok, Res, Rest} -> + {error, {asn1, + {encode_decode_mismatch, + {{Module, Type, Value}, {Res,Rest}}}}}; + Error -> + {error, {asn1, + {{decode, + {Module, Type, Value}, Error}}}} + end. + value(Module, Type) -> value(Module, Type, []). value(Module, Type, Includes) -> diff --git a/lib/asn1/src/asn1ct_gen.erl b/lib/asn1/src/asn1ct_gen.erl index 84c7f39d55..efbc6d6380 100644 --- a/lib/asn1/src/asn1ct_gen.erl +++ b/lib/asn1/src/asn1ct_gen.erl @@ -707,6 +707,7 @@ gen_exports([_|_]=L0, Prefix, Arity) -> pgen_dispatcher(Erules, []) -> gen_info_functions(Erules); pgen_dispatcher(Gen, Types) -> + %% MODULE HEAD emit(["-export([encode/2,decode/2]).",nl,nl]), gen_info_functions(Gen), @@ -714,6 +715,7 @@ pgen_dispatcher(Gen, Types) -> NoFinalPadding = lists:member(no_final_padding, Options), NoOkWrapper = proplists:get_bool(no_ok_wrapper, Options), + %% ENCODER Call = case Gen of #gen{erule=per,aligned=true} -> asn1ct_func:need({per,complete,1}), @@ -740,6 +742,7 @@ pgen_dispatcher(Gen, Types) -> end, emit([nl,nl]), + %% DECODER ReturnRest = proplists:get_bool(undec_rest, Gen#gen.options), Data = case Gen#gen.erule =:= ber andalso ReturnRest of true -> "Data0"; @@ -747,6 +750,12 @@ pgen_dispatcher(Gen, Types) -> end, emit(["decode(Type, ",Data,") ->",nl]), + + case NoOkWrapper of + false -> emit(["try",nl]); + true -> ok + end, + DecWrap = case {Gen,ReturnRest} of {#gen{erule=ber},false} -> @@ -754,32 +763,38 @@ pgen_dispatcher(Gen, Types) -> "element(1, ber_decode_nif(Data))"; {#gen{erule=ber},true} -> asn1ct_func:need({ber,ber_decode_nif,1}), - emit(["{Data,Rest} = ber_decode_nif(Data0),",nl]), + emit([" {Data,Rest} = ber_decode_nif(Data0),",nl]), "Data"; {_,_} -> "Data" end, - emit([case NoOkWrapper of - false -> "try"; - true -> "case" - end, " decode_disp(Type, ",DecWrap,") of",nl]), - case Gen of - #gen{erule=ber} -> - emit([" Result ->",nl]); - #gen{erule=per} -> - emit([" {Result,Rest} ->",nl]) - end, - case ReturnRest of - false -> result_line(NoOkWrapper, ["Result"]); - true -> result_line(NoOkWrapper, ["Result","Rest"]) + + DecodeDisp = ["decode_disp(Type, ",DecWrap,")"], + case {Gen,ReturnRest} of + {#gen{erule=ber},true} -> + emit([" Result = ",DecodeDisp,",",nl]), + result_line(NoOkWrapper, ["Result","Rest"]); + {#gen{erule=ber},false} -> + emit([" Result = ",DecodeDisp,",",nl]), + result_line(NoOkWrapper, ["Result"]); + + + {#gen{erule=per},true} -> + emit([" {Result,Rest} = ",DecodeDisp,",",nl]), + result_line(NoOkWrapper, ["Result","Rest"]); + {#gen{erule=per},false} -> + emit([" {Result,_Rest} = ",DecodeDisp,",",nl]), + result_line(NoOkWrapper, ["Result"]) end, + case NoOkWrapper of false -> emit([nl,try_catch(),nl,nl]); true -> - emit([nl,"end.",nl,nl]) + emit([".",nl,nl]) end, + %% REST of MODULE gen_decode_partial_incomplete(Gen), gen_partial_inc_dispatcher(Gen), @@ -787,7 +802,7 @@ pgen_dispatcher(Gen, Types) -> gen_dispatcher(Types, "decode_disp", "dec_"). result_line(NoOkWrapper, Items) -> - S = [" "|case NoOkWrapper of + S = [" "|case NoOkWrapper of false -> result_line_1(["ok"|Items]); true -> result_line_1(Items) end], diff --git a/lib/asn1/test/asn1_SUITE.erl b/lib/asn1/test/asn1_SUITE.erl index b98a704e28..bfeffa969f 100644 --- a/lib/asn1/test/asn1_SUITE.erl +++ b/lib/asn1/test/asn1_SUITE.erl @@ -1355,8 +1355,8 @@ xref_export_all(_Config) -> [] -> ok; [_|_] -> - S = [io_lib:format("~p:~p/~p\n", [M,F,A]) || {M,F,A} <- Unused], - io:format("There are unused functions:\n\n~s\n", [S]), + Msg = [io_lib:format("~p:~p/~p\n", [M,F,A]) || {M,F,A} <- Unused], + io:format("There are unused functions:\n\n~s\n", [Msg]), ?t:fail(unused_functions) end. diff --git a/lib/asn1/vsn.mk b/lib/asn1/vsn.mk index ef83b9e3dc..4cd89089e9 100644 --- a/lib/asn1/vsn.mk +++ b/lib/asn1/vsn.mk @@ -1 +1 @@ -ASN1_VSN = 5.0.3 +ASN1_VSN = 5.0.4 diff --git a/lib/common_test/doc/src/Makefile b/lib/common_test/doc/src/Makefile index b60b04c4ae..293ef591cb 100644 --- a/lib/common_test/doc/src/Makefile +++ b/lib/common_test/doc/src/Makefile @@ -60,6 +60,7 @@ XML_REF6_FILES = common_test_app.xml XML_PART_FILES = part.xml XML_CHAPTER_FILES = \ + introduction.xml \ basics_chapter.xml \ getting_started_chapter.xml \ install_chapter.xml \ @@ -74,8 +75,7 @@ XML_CHAPTER_FILES = \ event_handler_chapter.xml \ ct_hooks_chapter.xml \ dependencies_chapter.xml \ - notes.xml \ - notes_history.xml + notes.xml BOOK_FILES = book.xml diff --git a/lib/common_test/doc/src/ct.xml b/lib/common_test/doc/src/ct.xml index 1a3cfdb0c5..afd8741cd1 100644 --- a/lib/common_test/doc/src/ct.xml +++ b/lib/common_test/doc/src/ct.xml @@ -1060,6 +1060,42 @@ </desc> </func> + <func> + <name>remaining_test_procs() -> {TestProcs,SharedGL,OtherGLs}</name> + <fsummary>>This function will return the identity of test- and group + leader processes that are still running at the time of this call.</fsummary> + <type> + <v>TestProcs = [{pid(),GL}]</v> + <v>GL = pid()</v> + <v>SharedGL = pid()</v> + <v>OtherGLs = [pid()]</v> + </type> + <desc><marker id="remaining_test_procs-0"/> + <p>This function will return the identity of test- and group + leader processes that are still running at the time of this call. + <c>TestProcs</c> are processes in the system that have a Common Test IO + process as group leader. <c>SharedGL</c> is the central Common Test + IO process, responsible for printing to log files for configuration + functions and sequentially executing test cases. <c>OtherGLs</c> are + Common Test IO processes that print to log files for test cases + in parallel test case groups.</p> + <p>The process information returned by this function may be + used to locate and terminate remaining processes after tests have + finished executing. The function would typically by called from + Common Test Hook functions.</p> + <p>Note that processes that execute configuration functions or + test cases are never included in <c>TestProcs</c>. It is therefore safe + to use post configuration hook functions (such as post_end_per_suite, + post_end_per_group, post_end_per_testcase) to terminate all processes + in <c>TestProcs</c> that have the current group leader process as its group + leader.</p> + <p>Note also that the shared group leader (<c>SharedGL</c>) must never be + terminated by the user, only by Common Test. Group leader processes + for parallel test case groups (<c>OtherGLs</c>) may however be terminated + in post_end_per_group hook functions.</p> + </desc> + </func> + <func> <name>remove_config(Callback, Config) -> ok</name> <fsummary>Removes configuration variables (together with diff --git a/lib/common_test/doc/src/notes.xml b/lib/common_test/doc/src/notes.xml index b039023e0f..c6b928bb5d 100644 --- a/lib/common_test/doc/src/notes.xml +++ b/lib/common_test/doc/src/notes.xml @@ -33,6 +33,33 @@ <file>notes.xml</file> </header> +<section><title>Common_Test 1.15.3</title> + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + A new function, <c>ct:remaining_test_procs/0</c>, returns + the identity of test- and group leader processes that are + still running at the time of the call.</p> + <p> + Own Id: OTP-13832</p> + </item> + <item> + <p> + A "latest test result" link is now displayed in the + footer of each test index page, which performs a jump to + the most recently generated test index. This is useful + for making quick comparisons of results between test runs + without having to traverse the log file tree.</p> + <p> + Own Id: OTP-14281</p> + </item> + </list> + </section> + +</section> + <section><title>Common_Test 1.15.2</title> <section><title>Improvements and New Features</title> diff --git a/lib/common_test/src/ct.erl b/lib/common_test/src/ct.erl index 875301a8b2..69e371a30f 100644 --- a/lib/common_test/src/ct.erl +++ b/lib/common_test/src/ct.erl @@ -89,6 +89,8 @@ -export([get_target_name/1]). -export([parse_table/1, listenv/1]). +-export([remaining_test_procs/0]). + %%---------------------------------------------------------------------- %% Exported types %%---------------------------------------------------------------------- @@ -1474,3 +1476,36 @@ continue() -> %%% in order to let the test case proceed.</p> continue(TestCase) -> test_server:continue(TestCase). + + +%%%----------------------------------------------------------------- +%%% @spec remaining_test_procs() -> {TestProcs,SharedGL,OtherGLs} +%%% TestProcs = [{pid(),GL}] +%%% GL = SharedGL = pid() +%%% OtherGLs = [pid()] +%%% +%%% @doc <p>This function will return the identity of test- and group +%%% leader processes that are still running at the time of this call. +%%% TestProcs are processes in the system that have a Common Test IO +%%% process as group leader. SharedGL is the central Common Test +%%% IO process, responsible for printing to log files for configuration +%%% functions and sequentially executing test cases. OtherGLs are +%%% Common Test IO processes that print to log files for test cases +%%% in parallel test case groups.</p> +%%% <p>The process information returned by this function may be +%%% used to locate and terminate remaining processes after tests have +%%% finished executing. The function would typically by called from +%%% Common Test Hook functions.</p> +%%% <p>Note that processes that execute configuration functions or +%%% test cases are never included in TestProcs. It is therefore safe +%%% to use post configuration hook functions (such as post_end_per_suite, +%%% post_end_per_group, post_end_per_testcase) to terminate all processes +%%% in TestProcs that have the current group leader process as its group +%%% leader.</p> +%%% <p>Note also that the shared group leader (SharedGL) must never be +%%% terminated by the user, only by Common Test. Group leader processes +%%% for parallel test case groups (OtherGLs) may however be terminated +%%% in post_end_per_group hook functions.</p> +%%% +remaining_test_procs() -> + ct_util:remaining_test_procs(). diff --git a/lib/common_test/src/ct_config.erl b/lib/common_test/src/ct_config.erl index b3f983dd46..6c87b11f8d 100644 --- a/lib/common_test/src/ct_config.erl +++ b/lib/common_test/src/ct_config.erl @@ -81,6 +81,7 @@ start(Mode) -> do_start(Parent) -> process_flag(trap_exit,true), + ct_util:mark_process(), register(ct_config_server,self()), ct_util:create_table(?attr_table,bag,#ct_conf.key), {ok,StartDir} = file:get_cwd(), diff --git a/lib/common_test/src/ct_default_gl.erl b/lib/common_test/src/ct_default_gl.erl index d1b52e5f4f..9ae430c546 100644 --- a/lib/common_test/src/ct_default_gl.erl +++ b/lib/common_test/src/ct_default_gl.erl @@ -55,6 +55,7 @@ stop() -> init([ParentGL]) -> register(?MODULE, self()), + ct_util:mark_process(), {ok,#{parent_gl_pid => ParentGL, parent_gl_monitor => erlang:monitor(process,ParentGL)}}. diff --git a/lib/common_test/src/ct_event.erl b/lib/common_test/src/ct_event.erl index 1a0ee4f3cd..8b5bba7600 100644 --- a/lib/common_test/src/ct_event.erl +++ b/lib/common_test/src/ct_event.erl @@ -137,6 +137,7 @@ is_alive() -> %% this function is called to initialize the event handler. %%-------------------------------------------------------------------- init(RecvPids) -> + ct_util:mark_process(), %% RecvPids = [{RecvTag,Pid}] {ok,#state{receivers=RecvPids}}. diff --git a/lib/common_test/src/ct_gen_conn.erl b/lib/common_test/src/ct_gen_conn.erl index badb7c52ae..456bfd8bd1 100644 --- a/lib/common_test/src/ct_gen_conn.erl +++ b/lib/common_test/src/ct_gen_conn.erl @@ -186,9 +186,11 @@ end_log() -> do_within_time(Fun,Timeout) -> Self = self(), Silent = get(silent), - TmpPid = spawn_link(fun() -> put(silent,Silent), - R = Fun(), - Self ! {self(),R} + TmpPid = spawn_link(fun() -> + ct_util:mark_process(), + put(silent,Silent), + R = Fun(), + Self ! {self(),R} end), ConnPid = get(conn_pid), receive @@ -301,6 +303,7 @@ return({To,Ref},Result) -> init_gen(Parent,Opts) -> process_flag(trap_exit,true), + ct_util:mark_process(), put(silent,false), try (Opts#gen_opts.callback):init(Opts#gen_opts.name, Opts#gen_opts.address, diff --git a/lib/common_test/src/ct_hooks_lock.erl b/lib/common_test/src/ct_hooks_lock.erl index fea298e535..a82be288e1 100644 --- a/lib/common_test/src/ct_hooks_lock.erl +++ b/lib/common_test/src/ct_hooks_lock.erl @@ -78,6 +78,7 @@ release() -> %% @doc Initiates the server init(Id) -> + ct_util:mark_process(), {ok, #state{ id = Id }}. %% @doc Handling call messages diff --git a/lib/common_test/src/ct_logs.erl b/lib/common_test/src/ct_logs.erl index 028c265420..9861b1e521 100644 --- a/lib/common_test/src/ct_logs.erl +++ b/lib/common_test/src/ct_logs.erl @@ -666,6 +666,7 @@ log_timestamp({MS,S,US}) -> logger(Parent, Mode, Verbosity) -> register(?MODULE,self()), + ct_util:mark_process(), %%! Below is a temporary workaround for the limitation of %%! max one test run per second. %%! ---> @@ -1004,6 +1005,7 @@ print_to_log(async, FromPid, Category, TCGL, Content, EscChars, State) -> if FromPid /= TCGL -> IoFun = create_io_fun(FromPid, CtLogFd, EscChars), fun() -> + ct_util:mark_process(), test_server:permit_io(TCGL, self()), %% Since asynchronous io gets can get buffered if @@ -1035,6 +1037,7 @@ print_to_log(async, FromPid, Category, TCGL, Content, EscChars, State) -> end; true -> fun() -> + ct_util:mark_process(), unexpected_io(FromPid, Category, ?MAX_IMPORTANCE, Content, CtLogFd, EscChars) end @@ -3002,6 +3005,7 @@ simulate() -> S = self(), Pid = spawn(fun() -> register(?MODULE,self()), + ct_util:mark_process(), S ! {self(),started}, simulate_logger_loop() end), @@ -3129,8 +3133,8 @@ locate_priv_file(FileName) -> filename:join(get(ct_run_dir), FileName); _ -> %% executed on other process than ct_logs - {ok,RunDir} = get_log_dir(true), - filename:join(RunDir, FileName) + {ok,LogDir} = get_log_dir(true), + filename:join(LogDir, FileName) end, case filelib:is_file(PrivResultFile) of true -> @@ -3212,6 +3216,10 @@ get_ts_html_wrapper(TestName, Logdir, PrintLabel, Cwd, TableCols, Encoding) -> ?all_runs_name), Cwd), TestIndex = make_relative(filename:join(filename:dirname(CtLogdir), ?index_name), Cwd), + LatestTest = make_relative(filename:join(filename:dirname(CtLogdir), + ?suitelog_name++".latest.html"), + Cwd), + case Basic of true -> TileFile = filename:join(filename:join(CTPath,"priv"),"tile1.jpg"), @@ -3238,7 +3246,9 @@ get_ts_html_wrapper(TestName, Logdir, PrintLabel, Cwd, TableCols, Encoding) -> "<a href=\"", uri(AllRuns), "\">Test run history\n</a> | ", "<a href=\"", uri(TestIndex), - "\">Top level test index\n</a>\n</p>\n", + "\">Top level test index\n</a> | ", + "<a href=\"", uri(LatestTest), + "\">Latest test result</a>\n</p>\n", Copyright,"</center>\n</body>\n</html>\n"]}; _ -> Copyright = @@ -3285,7 +3295,9 @@ get_ts_html_wrapper(TestName, Logdir, PrintLabel, Cwd, TableCols, Encoding) -> "<a href=\"", uri(AllRuns), "\">Test run history\n</a> | ", "<a href=\"", uri(TestIndex), - "\">Top level test index\n</a>\n</p>\n", + "\">Top level test index\n</a> | ", + "<a href=\"", uri(LatestTest), + "\">Latest test result</a>\n</p>\n", Copyright,"</center>\n</body>\n</html>\n"]} end. diff --git a/lib/common_test/src/ct_master.erl b/lib/common_test/src/ct_master.erl index 44d3fb8f64..e2ea525cdd 100644 --- a/lib/common_test/src/ct_master.erl +++ b/lib/common_test/src/ct_master.erl @@ -346,6 +346,7 @@ init_master(Parent,NodeOptsList,EvHandlers,MasterLogDir,LogDirs, case whereis(ct_master) of undefined -> register(ct_master,self()), + ct_util:mark_process(), ok; _Pid -> io:format("~nWarning: ct_master already running!~n"), @@ -690,6 +691,7 @@ refresh_logs([],Refreshed) -> init_node_ctrl(MasterPid,Cookie,Opts) -> %% make sure tests proceed even if connection to master is lost process_flag(trap_exit, true), + ct_util:mark_process(), MasterNode = node(MasterPid), group_leader(whereis(user),self()), io:format("~n********** node_ctrl process ~w started on ~w **********~n", diff --git a/lib/common_test/src/ct_master_event.erl b/lib/common_test/src/ct_master_event.erl index d535d1274e..bd4d1efc92 100644 --- a/lib/common_test/src/ct_master_event.erl +++ b/lib/common_test/src/ct_master_event.erl @@ -116,6 +116,7 @@ sync_notify(Event) -> %% this function is called to initialize the event handler. %%-------------------------------------------------------------------- init(_) -> + ct_util:mark_process(), ct_master_logs:log("CT Master Event Handler started","",[]), {ok,#state{}}. diff --git a/lib/common_test/src/ct_master_logs.erl b/lib/common_test/src/ct_master_logs.erl index fd92f73f63..1308720823 100644 --- a/lib/common_test/src/ct_master_logs.erl +++ b/lib/common_test/src/ct_master_logs.erl @@ -88,6 +88,7 @@ stop() -> init(Parent,LogDir,Nodes) -> register(?MODULE,self()), + ct_util:mark_process(), Time = calendar:local_time(), RunDir = make_dirname(Time), RunDirAbs = filename:join(LogDir,RunDir), diff --git a/lib/common_test/src/ct_repeat.erl b/lib/common_test/src/ct_repeat.erl index c043c9846c..177ef37d1f 100644 --- a/lib/common_test/src/ct_repeat.erl +++ b/lib/common_test/src/ct_repeat.erl @@ -70,6 +70,7 @@ loop_test(If,Args) when is_list(Args) -> CtrlPid = self(), spawn( fun() -> + ct_util:mark_process(), stop_after(CtrlPid,Secs,ForceStop) end) end, @@ -134,6 +135,7 @@ spawn_tester(script,Ctrl,Args) -> spawn_tester(func,Ctrl,Opts) -> Tester = fun() -> + ct_util:mark_process(), case catch ct_run:run_test2(Opts) of {'EXIT',Reason} -> exit(Reason); diff --git a/lib/common_test/src/ct_run.erl b/lib/common_test/src/ct_run.erl index 9436236719..8c401cf3f5 100644 --- a/lib/common_test/src/ct_run.erl +++ b/lib/common_test/src/ct_run.erl @@ -250,6 +250,8 @@ finish(Tracing, ExitStatus, Args) -> end. script_start1(Parent, Args) -> + %% tag this process + ct_util:mark_process(), %% read general start flags Label = get_start_opt(label, fun([Lbl]) -> Lbl end, Args), Profile = get_start_opt(profile, fun([Prof]) -> Prof end, Args), @@ -956,7 +958,10 @@ run_test(StartOpts) when is_list(StartOpts) -> -spec run_test1_fun(_) -> fun(() -> no_return()). run_test1_fun(StartOpts) -> - fun() -> run_test1(StartOpts) end. + fun() -> + ct_util:mark_process(), + run_test1(StartOpts) + end. run_test1(StartOpts) when is_list(StartOpts) -> case proplists:get_value(refresh_logs, StartOpts) of @@ -1447,7 +1452,10 @@ run_testspec(TestSpec) -> -spec run_testspec1_fun(_) -> fun(() -> no_return()). run_testspec1_fun(TestSpec) -> - fun() -> run_testspec1(TestSpec) end. + fun() -> + ct_util:mark_process(), + run_testspec1(TestSpec) + end. run_testspec1(TestSpec) -> {ok,Cwd} = file:get_cwd(), @@ -1906,10 +1914,12 @@ possibly_spawn(true, Tests, Skip, Opts) -> CTUtilSrv = whereis(ct_util_server), Supervisor = fun() -> + ct_util:mark_process(), process_flag(trap_exit, true), link(CTUtilSrv), TestRun = fun() -> + ct_util:mark_process(), TestResult = (catch do_run_test(Tests, Skip, Opts)), case TestResult of {EType,_} = Error when EType == user_error; diff --git a/lib/common_test/src/ct_slave.erl b/lib/common_test/src/ct_slave.erl index 61e6446df8..0c16ad5980 100644 --- a/lib/common_test/src/ct_slave.erl +++ b/lib/common_test/src/ct_slave.erl @@ -318,6 +318,7 @@ monitor_master(MasterNode) -> % code of the masterdeath-waiter process monitor_master_int(MasterNode) -> + ct_util:mark_process(), erlang:monitor_node(MasterNode, true), receive {nodedown, MasterNode}-> diff --git a/lib/common_test/src/ct_telnet_client.erl b/lib/common_test/src/ct_telnet_client.erl index c8d217cd2a..76e4b9ea70 100644 --- a/lib/common_test/src/ct_telnet_client.erl +++ b/lib/common_test/src/ct_telnet_client.erl @@ -118,6 +118,7 @@ get_data(Pid) -> %%%----------------------------------------------------------------- %%% Internal functions init(Parent, Server, Port, Timeout, KeepAlive, NoDelay, ConnName) -> + ct_util:mark_process(), case gen_tcp:connect(Server, Port, [list,{packet,0},{nodelay,NoDelay}], Timeout) of {ok,Sock} -> dbg("~tp connected to: ~tp (port: ~w, keep_alive: ~w)\n", diff --git a/lib/common_test/src/ct_testspec.erl b/lib/common_test/src/ct_testspec.erl index bb445bb0d2..bd3755722f 100644 --- a/lib/common_test/src/ct_testspec.erl +++ b/lib/common_test/src/ct_testspec.erl @@ -1425,7 +1425,12 @@ skip_groups1(Suite,Groups,Cmt,Suites0) -> GrAndCases1 = GrAndCases0 ++ SkipGroups, insert_in_order({Suite,GrAndCases1},Suites0,replace); false -> - insert_in_order({Suite,SkipGroups},Suites0,replace) + case Suites0 of + [{all,_}=All|Skips]-> + [All|Skips++[{Suite,SkipGroups}]]; + _ -> + insert_in_order({Suite,SkipGroups},Suites0,replace) + end end. skip_cases(Node,Dir,Suite,Cases,Cmt,Tests,false) when is_list(Cases) -> diff --git a/lib/common_test/src/ct_util.erl b/lib/common_test/src/ct_util.erl index 3c0fead5b2..10a06d5c88 100644 --- a/lib/common_test/src/ct_util.erl +++ b/lib/common_test/src/ct_util.erl @@ -65,6 +65,9 @@ -export([warn_duplicates/1]). +-export([mark_process/0, mark_process/1, is_marked/1, is_marked/2, + remaining_test_procs/0]). + -export([get_profile_data/0, get_profile_data/1, get_profile_data/2, open_url/3]). @@ -126,6 +129,7 @@ start(Mode, LogDir, Verbosity) -> do_start(Parent, Mode, LogDir, Verbosity) -> process_flag(trap_exit,true), register(ct_util_server,self()), + mark_process(), create_table(?conn_table,#conn.handle), create_table(?board_table,2), create_table(?suite_table,#suite_data.key), @@ -934,6 +938,70 @@ warn_duplicates(Suites) -> %%% @spec %%% %%% @doc +mark_process() -> + mark_process(system). + +mark_process(Type) -> + put(ct_process_type, Type). + +is_marked(Pid) -> + is_marked(Pid, system). + +is_marked(Pid, Type) -> + case process_info(Pid, dictionary) of + {dictionary,List} -> + Type == proplists:get_value(ct_process_type, List); + undefined -> + false + end. + +remaining_test_procs() -> + Procs = processes(), + {SharedGL,OtherGLs,Procs2} = + lists:foldl( + fun(Pid, ProcTypes = {Shared,Other,Procs1}) -> + case is_marked(Pid, group_leader) of + true -> + if not is_pid(Shared) -> + case test_server_io:get_gl(true) of + Pid -> + {Pid,Other, + lists:delete(Pid,Procs1)}; + _ -> + {Shared,[Pid|Other],Procs1} + end; + true -> % SharedGL already found + {Shared,[Pid|Other],Procs1} + end; + false -> + case is_marked(Pid) of + true -> + {Shared,Other,lists:delete(Pid,Procs1)}; + false -> + ProcTypes + end + end + end, {undefined,[],Procs}, Procs), + + AllGLs = [SharedGL | OtherGLs], + TestProcs = + lists:flatmap(fun(Pid) -> + case process_info(Pid, group_leader) of + {group_leader,GL} -> + case lists:member(GL, AllGLs) of + true -> [{Pid,GL}]; + false -> [] + end; + undefined -> + [] + end + end, Procs2), + {TestProcs, SharedGL, OtherGLs}. + +%%%----------------------------------------------------------------- +%%% @spec +%%% +%%% @doc get_profile_data() -> get_profile_data(all). diff --git a/lib/common_test/src/ct_webtool.erl b/lib/common_test/src/ct_webtool.erl index 9016aca899..82aa78fc4b 100644 --- a/lib/common_test/src/ct_webtool.erl +++ b/lib/common_test/src/ct_webtool.erl @@ -343,6 +343,7 @@ code_change(_,State,_)-> % Start the gen_server %---------------------------------------------------------------------- init({Path,Config})-> + ct_util:mark_process(), case filelib:is_dir(Path) of true -> {ok, Table} = get_tool_files_data(), diff --git a/lib/common_test/src/ct_webtool_sup.erl b/lib/common_test/src/ct_webtool_sup.erl index c02ec69d04..6c6dbde0a6 100644 --- a/lib/common_test/src/ct_webtool_sup.erl +++ b/lib/common_test/src/ct_webtool_sup.erl @@ -46,6 +46,7 @@ stop(Pid)-> %% {error, Reason} %%---------------------------------------------------------------------- init(_StartArgs) -> + ct_util:mark_process(), %%Child1 = %%Child2 ={webcover_backend,{webcover_backend,start_link,[]},permanent,2000,worker,[webcover_backend]}, %%{ok,{{simple_one_for_one,5,10},[Child1]}}. diff --git a/lib/common_test/src/cth_log_redirect.erl b/lib/common_test/src/cth_log_redirect.erl index 8b29d0f96d..b05f0bd28b 100644 --- a/lib/common_test/src/cth_log_redirect.erl +++ b/lib/common_test/src/cth_log_redirect.erl @@ -56,6 +56,7 @@ id(_Opts) -> ?MODULE. init(?MODULE, _Opts) -> + ct_util:mark_process(), error_logger:add_report_handler(?MODULE), tc_log_async. @@ -121,8 +122,8 @@ handle_event({_Type,GL,_Msg}, #eh_state{handle_remote_events = false} = State) when node(GL) /= node() -> {ok, State}; handle_event(Event, #eh_state{log_func = LogFunc} = State) -> - case lists:keyfind(sasl, 1, application:which_applications()) of - false -> + case whereis(sasl_sup) of + undefined -> sasl_not_started; _Else -> {ok, ErrLogType} = application:get_env(sasl, errlog_type), diff --git a/lib/common_test/src/test_server.erl b/lib/common_test/src/test_server.erl index 35a73e6d2e..7250041e13 100644 --- a/lib/common_test/src/test_server.erl +++ b/lib/common_test/src/test_server.erl @@ -415,6 +415,7 @@ run_test_case_apply(Mod, Func, Args, Name, RunInit, TimetrapData) -> St = #st{ref=Ref,pid=Pid,mf={Mod,Func},last_known_loc=unknown, status=starting,ret_val=[],comment="",timeout=infinity, config=hd(Args)}, + ct_util:mark_process(), run_test_case_msgloop(St). %% Ugly bug (pre R5A): @@ -785,6 +786,7 @@ spawn_fw_call(Mod,IPTC={init_per_testcase,Func},CurrConf,Pid, Why,Loc,SendTo) -> FwCall = fun() -> + ct_util:mark_process(), Skip = {skip,{failed,{Mod,init_per_testcase,Why}}}, %% if init_per_testcase fails, the test case %% should be skipped @@ -815,6 +817,7 @@ spawn_fw_call(Mod,EPTC={end_per_testcase,Func},EndConf,Pid, Why,_Loc,SendTo) -> FwCall = fun() -> + ct_util:mark_process(), {RetVal,Report} = case proplists:get_value(tc_status, EndConf) of undefined -> @@ -864,6 +867,7 @@ spawn_fw_call(Mod,EPTC={end_per_testcase,Func},EndConf,Pid, spawn_fw_call(FwMod,FwFunc,_,_Pid,{framework_error,FwError},_,SendTo) -> FwCall = fun() -> + ct_util:mark_process(), test_server_sup:framework_call(report, [framework_error, {{FwMod,FwFunc}, FwError}]), @@ -880,6 +884,7 @@ spawn_fw_call(FwMod,FwFunc,_,_Pid,{framework_error,FwError},_,SendTo) -> spawn_link(FwCall); spawn_fw_call(Mod,Func,CurrConf,Pid,Error,Loc,SendTo) -> + ct_util:mark_process(), {Func1,EndTCFunc} = case Func of CF when CF == init_per_suite; CF == end_per_suite; CF == init_per_group; CF == end_per_group -> @@ -918,6 +923,7 @@ start_job_proxy() -> %% The io_reply_proxy is not the most satisfying solution but it works... io_reply_proxy(ReplyTo) -> + ct_util:mark_process(), receive IoReply when is_tuple(IoReply), element(1, IoReply) == io_reply -> @@ -927,6 +933,7 @@ io_reply_proxy(ReplyTo) -> end. job_proxy_msgloop() -> + ct_util:mark_process(), receive %% @@ -1804,6 +1811,7 @@ break(CBM, TestCase, Comment) -> spawn_break_process(Pid, PName) -> spawn(fun() -> register(PName, self()), + ct_util:mark_process(), receive continue -> continue(Pid); cancel -> ok @@ -2001,6 +2009,7 @@ time_ms_apply(Func, TCPid, MultAndScale) -> user_timetrap_supervisor(Func, Spawner, TCPid, GL, T0, MultAndScale) -> process_flag(trap_exit, true), + ct_util:mark_process(), Spawner ! {self(),infinity}, MonRef = monitor(process, TCPid), UserTTSup = self(), @@ -2571,6 +2580,7 @@ run_on_shielded_node(Fun, CArgs) when is_function(Fun), is_list(CArgs) -> -spec start_job_proxy_fun(_, _) -> fun(() -> no_return()). start_job_proxy_fun(Master, Fun) -> fun () -> + ct_util:mark_process(), _ = start_job_proxy(), receive Ref -> diff --git a/lib/common_test/src/test_server_ctrl.erl b/lib/common_test/src/test_server_ctrl.erl index c70ea4ef9d..3a454a1e84 100644 --- a/lib/common_test/src/test_server_ctrl.erl +++ b/lib/common_test/src/test_server_ctrl.erl @@ -89,6 +89,7 @@ -define(logdir_ext, ".logs"). -define(data_dir_suffix, "_data/"). -define(suitelog_name, "suite.log"). +-define(suitelog_latest_name, "suite.log.latest"). -define(coverlog_name, "cover.html"). -define(raw_coverlog_name, "cover.log"). -define(cross_coverlog_name, "cross_cover.html"). @@ -1126,6 +1127,7 @@ init_tester(Mod, Func, Args, Dir, Name, {_,_,MinLev}=Levels, RejectIoReqs, CreatePrivDir, TCCallback, ExtraTools) -> process_flag(trap_exit, true), _ = test_server_io:start_link(), + put(app, common_test), put(test_server_name, Name), put(test_server_dir, Dir), put(test_server_total_time, 0), @@ -1150,6 +1152,12 @@ init_tester(Mod, Func, Args, Dir, Name, {_,_,MinLev}=Levels, end, %% before first print, read and set logging options + FWLogDir = + case test_server_sup:framework_call(get_log_dir, [], []) of + {ok,FwDir} -> FwDir; + _ -> filename:dirname(Dir) + end, + put(test_server_framework_logdir, FWLogDir), LogOpts = test_server_sup:framework_call(get_logopts, [], []), put(test_server_logopts, LogOpts), @@ -1712,6 +1720,12 @@ start_log_file() -> test_server_io:set_fd(html, Html), test_server_io:set_fd(unexpected_io, Unexpected), + %% we must assume the redirection file (to the latest suite index) can + %% be stored on the level above the log directory of the current test + TopDir = filename:dirname(get(test_server_framework_logdir)), + RedirectLink = filename:join(TopDir, ?suitelog_latest_name ++ ?html_ext), + make_html_link(RedirectLink, HtmlName, redirect), + make_html_link(filename:absname(?last_test ++ ?html_ext), HtmlName, filename:basename(Dir)), LinkName = filename:join(Dir, ?last_link), @@ -1740,11 +1754,18 @@ make_html_link(LinkName, Target, Explanation) -> false -> "file:" ++ uri_encode(Target) end, - H = [html_header(Explanation), - "<h1>Last test</h1>\n" - "<a href=\"",Href,"\">",Explanation,"</a>\n" - "</body>\n</html>\n"], + H = if Explanation == redirect -> + Meta = ["<meta http-equiv=\"refresh\" " + "content=\"0; url=", Href, "\" />\n"], + [html_header("redirect", Meta), "</html>\n"]; + true -> + [html_header(Explanation), + "<h1>Last test</h1>\n" + "<a href=\"",Href,"\">",Explanation,"</a>\n" + "</body>\n</html>\n"] + end, ok = write_html_file(LinkName, H). + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% start_minor_log_file(Mod, Func, ParallelTC) -> AbsName @@ -3705,6 +3726,7 @@ run_test_case(Ref, Num, Mod, Func, Args, RunInit, TimetrapData, Mode) -> spawn_link( fun() -> process_flag(trap_exit, true), + ct_util:mark_process(), _ = [put(Key, Val) || {Key,Val} <- Dictionary], set_io_buffering({tc,Main}), run_test_case1(Ref, Num, Mod, Func, Args, RunInit, @@ -5658,6 +5680,13 @@ html_header(Title) -> "<body bgcolor=\"white\" text=\"black\" " "link=\"blue\" vlink=\"purple\" alink=\"red\">\n"]. +html_header(Title, Meta) -> + ["<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">\n" + "<!-- autogenerated by '", atom_to_list(?MODULE), "'. -->\n" + "<html>\n" + "<head>\n" + "<title>", Title, "</title>\n"] ++ Meta ++ ["</head>\n"]. + open_html_file(File) -> open_utf8_file(File). diff --git a/lib/common_test/src/test_server_gl.erl b/lib/common_test/src/test_server_gl.erl index ce7682d101..24dd5cd54c 100644 --- a/lib/common_test/src/test_server_gl.erl +++ b/lib/common_test/src/test_server_gl.erl @@ -132,6 +132,7 @@ set_props(GL, PropList) -> %%% Internal functions. init([TSIO]) -> + ct_util:mark_process(group_leader), EscChars = case application:get_env(test_server, esc_chars) of {ok,ECBool} -> ECBool; _ -> true diff --git a/lib/common_test/src/test_server_io.erl b/lib/common_test/src/test_server_io.erl index 062e3bd8ff..ef31521950 100644 --- a/lib/common_test/src/test_server_io.erl +++ b/lib/common_test/src/test_server_io.erl @@ -184,6 +184,7 @@ reset_state() -> init([]) -> process_flag(trap_exit, true), + ct_util:mark_process(), Empty = gb_trees:empty(), {ok,Shared} = test_server_gl:start_link(self()), {ok,#st{fds=Empty,shared_gl=Shared,gls=gb_sets:empty(), @@ -262,7 +263,7 @@ handle_call(reset_state, From, #st{phase=stopping,pending_ops=Ops}=St) -> {Result,NewSt1} end, {noreply,St#st{pending_ops=[{From,Op}|Ops]}}; -handle_call(reset_state, _From, #st{fds=Fds,tags=Tags,gls=Gls, +handle_call(reset_state, _From, #st{fds=Fds,tags=Tags,shared_gl=Shared0,gls=Gls, offline_buffer=OfflineBuff}) -> %% close open log files lists:foreach(fun(Tag) -> @@ -273,6 +274,7 @@ handle_call(reset_state, _From, #st{fds=Fds,tags=Tags,gls=Gls, file:close(Fd) end end, Tags), + test_server_gl:stop(Shared0), GlList = gb_sets:to_list(Gls), _ = [test_server_gl:stop(GL) || GL <- GlList], timer:sleep(100), @@ -320,7 +322,7 @@ handle_call(finish, From, St) -> handle_info({'EXIT',Pid,normal}, #st{gls=Gls0,stopping=From}=St) -> Gls = gb_sets:delete_any(Pid, Gls0), - case gb_sets:is_empty(Gls) andalso stopping =/= undefined of + case gb_sets:is_empty(Gls) andalso From =/= undefined of true -> %% No more group leaders left. gen_server:reply(From, ok), @@ -329,6 +331,9 @@ handle_info({'EXIT',Pid,normal}, #st{gls=Gls0,stopping=From}=St) -> %% Wait for more group leaders to finish. {noreply,St#st{gls=Gls,phase=stopping}} end; +handle_info({'EXIT',Pid,killed}, #st{gls=Gls0}=St) -> + %% forced termination of group leader + {noreply,St#st{gls=gb_sets:delete_any(Pid, Gls0)}}; handle_info({'EXIT',_Pid,Reason}, _St) -> exit(Reason); handle_info(stop_group_leaders, #st{gls=Gls}=St) -> diff --git a/lib/common_test/src/test_server_node.erl b/lib/common_test/src/test_server_node.erl index f0f9cea6e0..b2d4f199c3 100644 --- a/lib/common_test/src/test_server_node.erl +++ b/lib/common_test/src/test_server_node.erl @@ -749,6 +749,7 @@ unpack(Bin) -> id(I) -> I. print_data(Port) -> + ct_util:mark_process(), receive {Port, {data, Bytes}} -> io:put_chars(Bytes), diff --git a/lib/common_test/src/test_server_sup.erl b/lib/common_test/src/test_server_sup.erl index 21f4be22fe..6ddbf1ad27 100644 --- a/lib/common_test/src/test_server_sup.erl +++ b/lib/common_test/src/test_server_sup.erl @@ -56,6 +56,7 @@ timetrap(Timeout0, Scale, Pid) -> timetrap(Timeout0, ReportTVal, Scale, Pid) -> process_flag(priority, max), + ct_util:mark_process(), Timeout = if not Scale -> Timeout0; true -> test_server:timetrap_scale_factor() * Timeout0 end, @@ -773,6 +774,7 @@ framework_call(Callback,Func,Args,DefaultReturn) -> false -> ok end, + ct_util:mark_process(), try apply(Mod,Func,Args) of Result -> Result @@ -850,6 +852,7 @@ util_start() -> undefined -> spawn_link(fun() -> register(?MODULE, self()), + put(app, common_test), util_loop(#util_state{starter=Starter}) end), ok; diff --git a/lib/common_test/src/vts.erl b/lib/common_test/src/vts.erl index 99a109cfe8..83fcde2f48 100644 --- a/lib/common_test/src/vts.erl +++ b/lib/common_test/src/vts.erl @@ -157,6 +157,7 @@ test_info(_VtsPid,Type,Data) -> init(Parent) -> register(?MODULE,self()), process_flag(trap_exit,true), + ct_util:mark_process(), Parent ! {self(),started}, {ok,Cwd} = file:get_cwd(), InitState = #state{start_dir=Cwd}, @@ -284,6 +285,7 @@ run_test1(State=#state{tests=Tests,current_log_dir=LogDir, logopts=LogOpts}) -> Self=self(), RunTest = fun() -> + ct_util:mark_process(), case ct_run:do_run(Tests,[],LogDir,LogOpts) of {error,_Reason} -> aborted(); diff --git a/lib/common_test/test/Makefile b/lib/common_test/test/Makefile index 0d9149f489..ecd1f727a2 100644 --- a/lib/common_test/test/Makefile +++ b/lib/common_test/test/Makefile @@ -73,7 +73,8 @@ MODULES= \ ct_log_SUITE \ ct_SUITE \ ct_keep_logs_SUITE \ - ct_unicode_SUITE + ct_unicode_SUITE \ + ct_auto_clean_SUITE ERL_FILES= $(MODULES:%=%.erl) HRL_FILES= test_server_test_lib.hrl diff --git a/lib/common_test/test/ct_auto_clean_SUITE.erl b/lib/common_test/test/ct_auto_clean_SUITE.erl new file mode 100644 index 0000000000..fd81430d0d --- /dev/null +++ b/lib/common_test/test/ct_auto_clean_SUITE.erl @@ -0,0 +1,262 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2009-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(ct_auto_clean_SUITE). + +-compile(export_all). + +-include_lib("common_test/include/ct.hrl"). +-include_lib("common_test/include/ct_event.hrl"). + +-define(eh, ct_test_support_eh). + +%%-------------------------------------------------------------------- +%% Function: init_per_suite(Config0) -> Config1 | {skip,Reason} +%% +%% Config0 = Config1 = [tuple()] +%% A list of key/value pairs, holding the test case configuration. +%% Reason = term() +%% The reason for skipping the suite. +%% +%% Description: Since Common Test starts another Test Server +%% instance, the tests need to be performed on a separate node (or +%% there will be clashes with logging processes etc). +%%-------------------------------------------------------------------- +init_per_suite(Config) -> + DataDir = ?config(data_dir, Config), + CTHs = filelib:wildcard(filename:join(DataDir,"cth_*.erl")), + ct:pal("CTHs: ~p",[CTHs]), + [ct:pal("Compiling ~p: ~p", + [FileName,compile:file(FileName,[{outdir,DataDir},debug_info])]) || + FileName <- CTHs], + ct_test_support:init_per_suite([{path_dirs,[DataDir]} | Config]). + +%%-------------------------------------------------------------------- +%% Function: end_per_suite(Config) -> void() +%% +%% Config = [tuple()] +%% A list of key/value pairs, holding the test case configuration. +%% +%% Description: Cleanup after the suite. +%%-------------------------------------------------------------------- +end_per_suite(Config) -> + ct_test_support:end_per_suite(Config). + +%%-------------------------------------------------------------------- +%% Function: init_per_testcase(TestCase, Config0) -> Config1 | +%% {skip,Reason} +%% TestCase = atom() +%% Name of the test case that is about to run. +%% Config0 = Config1 = [tuple()] +%% A list of key/value pairs, holding the test case configuration. +%% Reason = term() +%% The reason for skipping the test case. +%% +%% Description: Initialization before each test case. +%% +%% Note: This function is free to add any key/value pairs to the Config +%% variable, but should NOT alter/remove any existing entries. +%%-------------------------------------------------------------------- +init_per_testcase(TestCase, Config) -> + ct_test_support:init_per_testcase(TestCase, Config). + +%%-------------------------------------------------------------------- +%% Function: end_per_testcase(TestCase, Config) -> void() +%% +%% TestCase = atom() +%% Name of the test case that is finished. +%% Config = [tuple()] +%% A list of key/value pairs, holding the test case configuration. +%% +%% Description: Cleanup after each test case. +%%-------------------------------------------------------------------- +end_per_testcase(TestCase, Config) -> + ct_test_support:end_per_testcase(TestCase, Config). + +%%-------------------------------------------------------------------- +%% Function: all(Clause) -> Descr | TestCases | {skip,Reason} +%% +%% Clause = doc | suite +%% Indicates expected return value. +%% Descr = [string()] | [] +%% String that describes the test suite. +%% TestCases = [TestCase] +%% TestCase = atom() +%% Name of a test case. +%% Reason = term() +%% The reason for skipping the test suite. +%% +%% Description: Returns a description of the test suite (doc) and a +%% list of all test cases in the suite (suite). +%%-------------------------------------------------------------------- +suite() -> [{ct_hooks,[ts_install_cth]}]. + +all() -> + [clean]. + +groups() -> + []. + +init_per_group(_GroupName, Config) -> + Config. + +end_per_group(_GroupName, Config) -> + Config. + +%%-------------------------------------------------------------------- +%% TEST CASES +%%-------------------------------------------------------------------- + +%%-------------------------------------------------------------------- +%% Function: TestCase(Arg) -> Descr | Spec | ok | exit() | {skip,Reason} +%% +%% Arg = doc | suite | Config +%% Indicates expected behaviour and return value. +%% Config = [tuple()] +%% A list of key/value pairs, holding the test case configuration. +%% Descr = [string()] | [] +%% String that describes the test case. +%% Spec = [tuple()] | [] +%% A test specification. +%% Reason = term() +%% The reason for skipping the test case. +%% +%% Description: Test case function. Returns a description of the test +%% case (doc), then returns a test specification (suite), +%% or performs the actual test (Config). +%%-------------------------------------------------------------------- + +%%%----------------------------------------------------------------- +%%% + +clean(Config) when is_list(Config) -> + DataDir = ?config(data_dir, Config), + + ACSuite = filename:join(DataDir, "ac_SUITE"), + Opts0 = ct_test_support:get_opts(Config), + Opts = eh_opts(Config) ++ Opts0 ++ [{suite,ACSuite}, + {ct_hooks,[cth_auto_clean]}], + + ERPid = ct_test_support:start_event_receiver(Config), + + ok = ct_test_support:run(Opts, Config), + + Events = ct_test_support:get_events(ERPid, Config), + ct_test_support:log_events(?FUNCTION_NAME, + ct_test_support:reformat(Events, ?eh), + ?config(priv_dir, Config), + Opts), + TestEvents = events_to_check(?FUNCTION_NAME), + ok = ct_test_support:verify_events(TestEvents, Events, Config). + + +%%%----------------------------------------------------------------- +%%% HELP FUNCTIONS +%%%----------------------------------------------------------------- + +eh_opts(Config) -> + Level = ?config(trace_level, Config), + [{event_handler,{?eh,[{cbm,ct_test_support},{trace_level,Level}]}}]. + +events_to_check(Test) -> + %% 2 tests (ct:run_test + script_start) is default + events_to_check(Test, 2). + +events_to_check(_, 0) -> + []; +events_to_check(Test, N) -> + events(Test) ++ events_to_check(Test, N-1). + +events(clean) -> + [ + {?eh,start_logging,{'DEF','RUNDIR'}}, + {?eh,test_start,{'DEF',{'START_TIME','LOGDIR'}}}, + {?eh,start_info,{1,1,9}}, + + {?eh,tc_start,{ac_SUITE,init_per_suite}}, + {?eh,tc_done,{ac_SUITE,init_per_suite,ok}}, + + {?eh,tc_start,{ac_SUITE,tc1}}, + {?eh,tc_done,{ac_SUITE,tc1,ok}}, + + {?eh,test_stats,{1,0,{0,0}}}, + + {?eh,tc_start,{ac_SUITE,tc2}}, + {?eh,tc_done,{ac_SUITE,tc2,ok}}, + + {?eh,test_stats,{2,0,{0,0}}}, + + [{?eh,tc_start,{ac_SUITE,{init_per_group,s1,[]}}}, + {?eh,tc_done,{ac_SUITE,{init_per_group,s1,[]},ok}}, + + {?eh,tc_start,{ac_SUITE,stc1}}, + {?eh,tc_done,{ac_SUITE,stc1,ok}}, + + {?eh,test_stats,{3,0,{0,0}}}, + + {?eh,tc_start,{ac_SUITE,stc2}}, + {?eh,tc_done,{ac_SUITE,stc2,ok}}, + + {?eh,test_stats,{4,0,{0,0}}}, + + {?eh,tc_start,{ac_SUITE,{end_per_group,s1,[]}}}, + {?eh,tc_done,{ac_SUITE,{end_per_group,s1,[]},ok}}], + + {parallel, + [{?eh,tc_start,{ac_SUITE,{init_per_group,p1,[parallel]}}}, + {?eh,tc_done,{ac_SUITE,{init_per_group,p1,[parallel]},ok}}, + + {?eh,tc_start,{ac_SUITE,ptc1}}, + {?eh,tc_start,{ac_SUITE,ptc2}}, + {?eh,tc_done,{ac_SUITE,ptc1,ok}}, + {?eh,test_stats,{5,0,{0,0}}}, + {?eh,tc_done,{ac_SUITE,ptc2,ok}}, + {?eh,test_stats,{6,0,{0,0}}}, + + {?eh,tc_start,{ac_SUITE,{end_per_group,p1,[parallel]}}}, + {?eh,tc_done,{ac_SUITE,{end_per_group,p1,[parallel]},ok}}]}, + + [{?eh,tc_start,{ac_SUITE,{init_per_group,s2,[]}}}, + {?eh,tc_done,{ac_SUITE,{init_per_group,s2,[]},ok}}, + + {?eh,tc_start,{ac_SUITE,stc1}}, + {?eh,tc_done,{ac_SUITE,stc1,ok}}, + + {?eh,test_stats,{7,0,{0,0}}}, + + {?eh,tc_start,{ac_SUITE,stc2}}, + {?eh,tc_done,{ac_SUITE,stc2,ok}}, + + {?eh,test_stats,{8,0,{0,0}}}, + + {?eh,tc_start,{ac_SUITE,{end_per_group,s2,[]}}}, + {?eh,tc_done,{ac_SUITE,{end_per_group,s2,[]},ok}}], + + {?eh,tc_start,{ac_SUITE,tc1}}, + {?eh,tc_done,{ac_SUITE,tc1,ok}}, + + {?eh,test_stats,{9,0,{0,0}}}, + + {?eh,tc_start,{ac_SUITE,end_per_suite}}, + {?eh,tc_done,{ac_SUITE,end_per_suite,ok}}, + + {?eh,test_done,{'DEF','STOP_TIME'}}, + {?eh,stop_logging,[]} + ]. diff --git a/lib/common_test/test/ct_auto_clean_SUITE_data/ac_SUITE.erl b/lib/common_test/test/ct_auto_clean_SUITE_data/ac_SUITE.erl new file mode 100644 index 0000000000..dae7c1e22c --- /dev/null +++ b/lib/common_test/test/ct_auto_clean_SUITE_data/ac_SUITE.erl @@ -0,0 +1,181 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2009-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(ac_SUITE). + +-compile(export_all). + +-include_lib("common_test/include/ct.hrl"). + +%%-------------------------------------------------------------------- +%% @spec suite() -> Info +%% Info = [tuple()] +%% @end +%%-------------------------------------------------------------------- +suite() -> + [{timetrap,{seconds,30}}]. + +%%-------------------------------------------------------------------- +%% @spec init_per_suite(Config0) -> +%% Config1 | {skip,Reason} | {skip_and_save,Reason,Config1} +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +init_per_suite(Config) -> + start_processes(), + Config. + +%%-------------------------------------------------------------------- +%% @spec end_per_suite(Config0) -> term() | {save_config,Config1} +%% Config0 = Config1 = [tuple()] +%% @end +%%-------------------------------------------------------------------- +end_per_suite(_Config) -> + start_processes(), + ok. + +%%-------------------------------------------------------------------- +%% @spec init_per_group(GroupName, Config0) -> +%% Config1 | {skip,Reason} | {skip_and_save,Reason,Config1} +%% GroupName = atom() +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +init_per_group(_GroupName, Config) -> + start_processes(), + Config. + +%%-------------------------------------------------------------------- +%% @spec end_per_group(GroupName, Config0) -> +%% term() | {save_config,Config1} +%% GroupName = atom() +%% Config0 = Config1 = [tuple()] +%% @end +%%-------------------------------------------------------------------- +end_per_group(_GroupName, _Config) -> + start_processes(), + ok. + +%%-------------------------------------------------------------------- +%% @spec init_per_testcase(TestCase, Config0) -> +%% Config1 | {skip,Reason} | {skip_and_save,Reason,Config1} +%% TestCase = atom() +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +init_per_testcase(_TestCase, Config) -> + start_processes(), + Config. + +%%-------------------------------------------------------------------- +%% @spec end_per_testcase(TestCase, Config0) -> +%% term() | {save_config,Config1} | {fail,Reason} +%% TestCase = atom() +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +end_per_testcase(_TestCase, _Config) -> + start_processes(), + ok. + +%%-------------------------------------------------------------------- +%% @spec groups() -> [Group] +%% Group = {GroupName,Properties,GroupsAndTestCases} +%% GroupName = atom() +%% Properties = [parallel | sequence | Shuffle | {RepeatType,N}] +%% GroupsAndTestCases = [Group | {group,GroupName} | TestCase] +%% TestCase = atom() +%% Shuffle = shuffle | {shuffle,{integer(),integer(),integer()}} +%% RepeatType = repeat | repeat_until_all_ok | repeat_until_all_fail | +%% repeat_until_any_ok | repeat_until_any_fail +%% N = integer() | forever +%% @end +%%-------------------------------------------------------------------- +groups() -> + [{s1,[],[stc1,stc2]}, + {p1,[parallel],[ptc1,ptc2]}, + {s2,[],[stc1,stc2]}]. + +%%! What about nested groups?? + +%%-------------------------------------------------------------------- +%% @spec all() -> GroupsAndTestCases | {skip,Reason} +%% GroupsAndTestCases = [{group,GroupName} | TestCase] +%% GroupName = atom() +%% TestCase = atom() +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +all() -> + [ + [tc1,tc2], + {group,s1}, + {group,p1}, + {group,s2}, + tc1 + ]. + +tc1(_Config) -> + start_processes(), + ok. + +tc2(_Config) -> + start_processes(), + ok. + +stc1(_Config) -> + start_processes(), + ok. + +stc2(_Config) -> + start_processes(), + ok. + +ptc1(_Config) -> + start_processes(), + ok. + +ptc2(_Config) -> + start_processes(), + ok. + + +%%%----------------------------------------------------------------- +%%% + +start_processes() -> + Init = fun() -> + process_flag(trap_exit, true), + do_spawn(fun() -> receive _ -> ok end end), + receive _ -> + ok + end + end, + do_spawn(Init). + +do_spawn(Fun) -> + Pid = spawn(Fun), + ct:log("Process ~w started with group leader ~w", + [Pid,element(2, process_info(Pid, group_leader))]), + Pid. diff --git a/lib/common_test/test/ct_auto_clean_SUITE_data/cth_auto_clean.erl b/lib/common_test/test/ct_auto_clean_SUITE_data/cth_auto_clean.erl new file mode 100644 index 0000000000..137c81969d --- /dev/null +++ b/lib/common_test/test/ct_auto_clean_SUITE_data/cth_auto_clean.erl @@ -0,0 +1,214 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2009-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(cth_auto_clean). + +%% CTH Callbacks +-export([id/1, init/2, + pre_init_per_suite/3, post_init_per_suite/4, + pre_end_per_suite/3, post_end_per_suite/4, + pre_init_per_group/4, post_init_per_group/5, + pre_end_per_group/4, post_end_per_group/5, + pre_init_per_testcase/4, post_init_per_testcase/5, + pre_end_per_testcase/4, post_end_per_testcase/5]). + +id(_Opts) -> + ?MODULE. + +init(?MODULE, _Opts) -> + ok. + +pre_init_per_suite(_Suite, Config, State) -> + identify(?FUNCTION_NAME), + SharedGL = test_server_io:get_gl(true), + SharedGL = find_and_kill(), + do_until(fun() -> ct:remaining_test_procs() end, {[],SharedGL,[]}), + %% get status of processes at startup, to be compared with end result + {Config, [{all_procs,processes()} | State]}. + +post_init_per_suite(_Suite, _Config, Return, State) -> + identify(?FUNCTION_NAME), + SharedGL = find_and_kill(), + do_until(fun() -> ct:remaining_test_procs() end, {[],SharedGL,[]}), + {Return, State}. + +pre_end_per_suite(_Suite, Config, State) -> + identify(?FUNCTION_NAME), + SharedGL = find_and_kill(), + do_until(fun() -> ct:remaining_test_procs() end, {[],SharedGL,[]}), + {Config, State}. + +post_end_per_suite(_Suite, _Config, Return, State) -> + identify(?FUNCTION_NAME), + SharedGL = find_and_kill(), + do_until(fun() -> ct:remaining_test_procs() end, {[],SharedGL,[]}), + AllProcs = processes(), + Remaining = AllProcs--proplists:get_value(all_procs, State), + ct:pal("Final remaining processes = ~p", [Remaining]), + %% only the end_per_suite process shoud remain at this point! + Remaining = [self()], + {Return, State}. + +pre_init_per_group(_Suite, _Group, Config, State) -> + identify(?FUNCTION_NAME), + SharedGL = find_and_kill(procs_and_gls), + do_until(fun() -> ct:remaining_test_procs() end, {[],SharedGL,[]}), + {Config, State}. + +post_init_per_group(_Suite, _Group, _Config, Result, State) -> + identify(?FUNCTION_NAME), + SharedGL = find_and_kill(procs_and_gls), + do_until(fun() -> ct:remaining_test_procs() end, {[],SharedGL,[]}), + {Result, State}. + +pre_init_per_testcase(_Suite, _TC, Config, State) -> + identify(?FUNCTION_NAME), + ThisGL = group_leader(), + find_and_kill(proc, ThisGL), + case proplists:get_value(tc_group_properties, Config) of + [{name,_},parallel] -> + timer:sleep(1000); + _ -> + do_until(fun() -> element(1,ct:remaining_test_procs()) end, []) + end, + {Config, State}. + +post_init_per_testcase(_Suite, _TC, Config, Return, State) -> + identify(?FUNCTION_NAME), + ThisGL = group_leader(), + find_and_kill(proc, ThisGL), + case proplists:get_value(tc_group_properties, Config) of + [{name,_},parallel] -> + timer:sleep(1000); + _ -> + do_until(fun() -> element(1,ct:remaining_test_procs()) end, []) + end, + {Return, State}. + +pre_end_per_testcase(_Suite, _TC, Config, State) -> + identify(?FUNCTION_NAME), + ThisGL = group_leader(), + find_and_kill(proc, ThisGL), + case proplists:get_value(tc_group_properties, Config) of + [{name,_},parallel] -> + timer:sleep(1000); + _ -> + do_until(fun() -> element(1,ct:remaining_test_procs()) end, []) + end, + {Config, State}. + +post_end_per_testcase(_Suite, _TC, Config, Result, State) -> + identify(?FUNCTION_NAME), + ThisGL = group_leader(), + find_and_kill(proc, ThisGL), + case proplists:get_value(tc_group_properties, Config) of + [{name,_},parallel] -> + timer:sleep(1000); + _ -> + do_until(fun() -> element(1,ct:remaining_test_procs()) end, []) + end, + {Result, State}. + +pre_end_per_group(_Suite, _Group, Config, State) -> + identify(?FUNCTION_NAME), + SharedGL = find_and_kill(procs_and_gls), + do_until(fun() -> ct:remaining_test_procs() end, {[],SharedGL,[]}), + {Config, State}. + +post_end_per_group(_Suite, _Group, _Config, Return, State) -> + identify(?FUNCTION_NAME), + SharedGL = find_and_kill(procs_and_gls), + do_until(fun() -> ct:remaining_test_procs() end, {[],SharedGL,[]}), + {Return, State}. + + +%%%----------------------------------------------------------------- +%%% HELP FUNCTIONS +%%%----------------------------------------------------------------- + +identify(Func) -> + ct:pal("********** THIS IS ~w on ~w", [Func, self()]), + ok. + +find_and_kill() -> + find_and_kill(procs). + +find_and_kill(procs) -> + {Procs,SharedGL,_ParallelGLs} = ct:remaining_test_procs(), + ct:pal("Remaining test processes = ~p", [pi(Procs)]), + [pkill(P, kill) || {P,_GL} <- Procs], + SharedGL; + +find_and_kill(procs_and_gls) -> + {Procs,SharedGL,GLs} = ct:remaining_test_procs(), + ct:pal("Remaining test processes = ~p", [pi(Procs)]), + [pkill(P, kill) || {P,_GL} <- Procs], + ct:pal("Remaining group leaders = ~p", [pi(GLs)]), + [pkill(GL, kill) || GL <- GLs, GL /= SharedGL], + SharedGL. + +find_and_kill(proc, ProcGL) -> + {Procs,SharedGL,GLs} = ct:remaining_test_procs(), + ct:pal("Remaining test processes = ~p", [pi(Procs++GLs)]), + [pkill(P, kill) || {P,GL} <- Procs, GL == ProcGL], + SharedGL. + +pi([{P,_GL}|Ps]) -> + pi([P|Ps]); +pi([P|Ps]) -> + case node() == node(P) of + true -> + {_,GL} = process_info(P,group_leader), + {_,CF} = process_info(P,current_function), + {_,IC} = process_info(P,initial_call), + {_,D} = process_info(P,dictionary), + Shared = test_server_io:get_gl(true), + User = whereis(user), + if (GL /= P) and (GL /= Shared) and (GL /= User) -> + [{P,GL,CF,IC,D} | pi([GL|Ps])]; + true -> + [{P,GL,CF,IC,D} | pi(Ps)] + end; + false -> + pi(Ps) + end; +pi([]) -> + []. + +do_until(Fun, Until) -> + io:format("Will do until ~p~n", [Until]), + do_until(Fun, Until, 1000). + +do_until(_, Until, 0) -> + io:format("Couldn't get ~p~n", [Until]), + exit({not_reached,Until}); + +do_until(Fun, Until, N) -> + case Fun() of + Until -> + ok; + _Tmp -> + do_until(Fun, Until, N-1) + end. + +pkill(P, How) -> + ct:pal("KILLING ~w NOW!", [P]), + exit(P, How). + diff --git a/lib/common_test/test/test_server_test_lib.erl b/lib/common_test/test/test_server_test_lib.erl index e3d987a2ea..9ee946af0b 100644 --- a/lib/common_test/test/test_server_test_lib.erl +++ b/lib/common_test/test/test_server_test_lib.erl @@ -121,7 +121,7 @@ parse_suite(FileName) -> end. fline(Fd) -> - case prim_file:read_line(Fd) of + case file:read_line(Fd) of eof -> eof; {ok, Line} -> Line end. diff --git a/lib/common_test/vsn.mk b/lib/common_test/vsn.mk index 7b959ebfe3..96fdc89853 100644 --- a/lib/common_test/vsn.mk +++ b/lib/common_test/vsn.mk @@ -1 +1 @@ -COMMON_TEST_VSN = 1.15.2 +COMMON_TEST_VSN = 1.15.3 diff --git a/lib/compiler/doc/src/Makefile b/lib/compiler/doc/src/Makefile index 254445c111..13210de040 100644 --- a/lib/compiler/doc/src/Makefile +++ b/lib/compiler/doc/src/Makefile @@ -39,7 +39,7 @@ XML_APPLICATION_FILES = ref_man.xml XML_REF3_FILES = compile.xml XML_PART_FILES = -XML_CHAPTER_FILES = notes.xml notes_history.xml +XML_CHAPTER_FILES = notes.xml BOOK_FILES = book.xml diff --git a/lib/compiler/doc/src/compile.xml b/lib/compiler/doc/src/compile.xml index b398871ddf..06afc55c07 100644 --- a/lib/compiler/doc/src/compile.xml +++ b/lib/compiler/doc/src/compile.xml @@ -233,6 +233,15 @@ module.beam: module.erl \ header.hrl</code> </item> + <tag><c>makedep_side_effect</c></tag> + <item> + <p>The dependecies are created as a side effect to the + normal compilation process. This means that the object + file will also be produced. This option override the + <c>makedep</c> option. + </p> + </item> + <tag><c>{makedep_output, Output}</c></tag> <item> <p>Writes generated rules to <c>Output</c> instead of the diff --git a/lib/compiler/doc/src/notes.xml b/lib/compiler/doc/src/notes.xml index 433fc3b86e..f4a3f9875b 100644 --- a/lib/compiler/doc/src/notes.xml +++ b/lib/compiler/doc/src/notes.xml @@ -32,6 +32,22 @@ <p>This document describes the changes made to the Compiler application.</p> +<section><title>Compiler 7.1.4</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p>The '<c>deterministic</c>' option was not recognized + when given in a <c>-compile()</c> attribute in the source + code.</p> + <p> + Own Id: OTP-14773 Aux Id: ERL-498 </p> + </item> + </list> + </section> + +</section> + <section><title>Compiler 7.1.3</title> <section><title>Fixed Bugs and Malfunctions</title> @@ -510,6 +526,22 @@ </section> + +<section><title>Compiler 6.0.3.1</title> + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p>Fail labels on guard BIFs weren't taken into account + during an optimization pass, and a bug in the validation + pass sometimes prevented this from being noticed when a + fault occurred.</p> + <p> + Own Id: OTP-14522 Aux Id: ERIERL-48 </p> + </item> + </list> + </section> +</section> + <section><title>Compiler 6.0.3</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/compiler/internal_doc/cerl-notes.md b/lib/compiler/internal_doc/cerl-notes.md new file mode 100644 index 0000000000..705fe8f42d --- /dev/null +++ b/lib/compiler/internal_doc/cerl-notes.md @@ -0,0 +1,75 @@ +Some notes on the cerl modules +============================== + +Maps in cerl_clauses:match/3 +---------------------------- + +Not much optimization is done for maps in `cerl_clauses:match/3`. + +The reason is that the inliner (`cerl_inline`) was not designed for +data types that depend on variables bound in the enclosing environment +(for example, the keys for maps). If we attempt to extend the +optimizations for maps similar to the optimizations for the other data +types, the inliner will crash for certain code. Here is an example of +code that would crash the inliner: + + t() -> + f(key). + + f(K) -> + case #{K => value} of + #{key := V} -> V + end. + +The reason for the crash is that the inliner works in several +passes and calls `cerl_clauses:match/3` twice. The inliner will +assume that the same result will be returned both times, but +for this example different bindings will be returned. + +Here is the rough outline of what happens: + +* The first time `cerl_clauses:match/3` will be asked to match the +pattern `#{K := V}` against `#{key => value}`. It cannot say more +than that the pattern *may* match. + +* Now the inliner will add the bindings to body of the clause (which +is simply `V`). In this case, the bindings are still empty, so +nothing is added. + +* The inliner will now do some substitutions and renaming. The +variable `K` will be replaced with `key`. + +* The next time `cerl_clauses:match/3` is called, it will be asked to +match the pattern `#{key := V}` against `#{key => value#}`. In this +case, there will be a match and the bindings can be extended with +`{V,value}`. + +* The inliner will see that the entire case can be removed. Only +the body for the clause needs to be kept. + +Thus, after inlining the function `t/0` will look like this: + + t() -> + V. + +The problem here is that the inliner assumed that the bindings from +the first and second call to `cer_clauses:match/3` would be the same. +It used the empty bindings from the first call for the body. + +The correct way would be to add the bindings from the second call: + + t() -> + let V = value in V. + +### How to fix this ### + +The inliner will need to call `cerl_clauses:match/3` after doing +all substitutions and renaming. It is not clear to me how difficult +that would be. I assume that the inliner is written the way it is +for a good reason. That means that switching the order things are +done would lead to correctness and/or performance problems. + +### What must also be done to fix this ### + +`cerl_inline:make_template/3` must be extended to create a template +for maps. That is relatively straightforward. diff --git a/lib/compiler/src/Makefile b/lib/compiler/src/Makefile index 9b22e5197b..9e96147787 100644 --- a/lib/compiler/src/Makefile +++ b/lib/compiler/src/Makefile @@ -93,16 +93,14 @@ MODULES = \ v3_codegen \ v3_core \ v3_kernel \ - v3_kernel_pp \ - v3_life + v3_kernel_pp BEAM_H = $(wildcard ../priv/beam_h/*.h) HRL_FILES= \ beam_disasm.hrl \ core_parse.hrl \ - v3_kernel.hrl \ - v3_life.hrl + v3_kernel.hrl YRL_FILE = core_parse.yrl @@ -187,7 +185,7 @@ release_docs_spec: # ---------------------------------------------------- $(EBIN)/beam_disasm.beam: $(EGEN)/beam_opcodes.hrl beam_disasm.hrl -$(EBIN)/beam_listing.beam: v3_life.hrl +$(EBIN)/beam_listing.beam: core_parse.hrl v3_kernel.hrl $(EBIN)/beam_validator.beam: beam_disasm.hrl $(EBIN)/cerl.beam: core_parse.hrl $(EBIN)/compile.beam: core_parse.hrl ../../stdlib/include/erl_compile.hrl @@ -200,8 +198,7 @@ $(EBIN)/sys_core_dsetel.beam: core_parse.hrl $(EBIN)/sys_core_fold.beam: core_parse.hrl $(EBIN)/sys_core_fold_lists.beam: core_parse.hrl $(EBIN)/sys_core_inline.beam: core_parse.hrl -$(EBIN)/v3_codegen.beam: v3_life.hrl +$(EBIN)/v3_codegen.beam: v3_kernel.hrl $(EBIN)/v3_core.beam: core_parse.hrl $(EBIN)/v3_kernel.beam: core_parse.hrl v3_kernel.hrl $(EBIN)/v3_kernel_pp.beam: v3_kernel.hrl -$(EBIN)/v3_life.beam: v3_kernel.hrl v3_life.hrl diff --git a/lib/compiler/src/beam_a.erl b/lib/compiler/src/beam_a.erl index cdb32d5d55..91acb19971 100644 --- a/lib/compiler/src/beam_a.erl +++ b/lib/compiler/src/beam_a.erl @@ -42,8 +42,7 @@ function({function,Name,Arity,CLabel,Is0}) -> Is = beam_jump:remove_unused_labels(Is1), {function,Name,Arity,CLabel,Is} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. @@ -59,8 +58,17 @@ rename_instrs([{call_only,A,F}|Is]) -> rename_instrs([{call_ext_only,A,F}|Is]) -> [{call_ext,A,F},return|rename_instrs(Is)]; rename_instrs([{'%live',_}|Is]) -> - %% When compiling from old .S files. + %% Ignore old type of live annotation. Only happens when compiling + %% from very old .S files. rename_instrs(Is); +rename_instrs([{get_list,S,D1,D2}|Is]) -> + %% Only happens when compiling from old .S files. + if + D1 =:= S -> + [{get_tl,S,D2},{get_hd,S,D1}|rename_instrs(Is)]; + true -> + [{get_hd,S,D1},{get_tl,S,D2}|rename_instrs(Is)] + end; rename_instrs([I|Is]) -> [rename_instr(I)|rename_instrs(Is)]; rename_instrs([]) -> []. diff --git a/lib/compiler/src/beam_asm.erl b/lib/compiler/src/beam_asm.erl index 9ecbb7884c..fa919ca862 100644 --- a/lib/compiler/src/beam_asm.erl +++ b/lib/compiler/src/beam_asm.erl @@ -24,7 +24,7 @@ -export([module/4]). -export([encode/2]). --export_type([fail/0,label/0,reg/0,src/0,module_code/0,function_name/0]). +-export_type([fail/0,label/0,reg/0,reg_num/0,src/0,module_code/0,function_name/0]). -import(lists, [map/2,member/2,keymember/3,duplicate/2,splitwith/2]). -include("beam_opcodes.hrl"). @@ -240,9 +240,7 @@ build_form(Id, Chunks0) when byte_size(Id) =:= 4, is_list(Chunks0) -> chunk(Id, Contents) when byte_size(Id) =:= 4, is_binary(Contents) -> Size = byte_size(Contents), - [<<Id/binary,Size:32>>,Contents|pad(Size)]; -chunk(Id, Contents) when is_list(Contents) -> - chunk(Id, list_to_binary(Contents)). + [<<Id/binary,Size:32>>,Contents|pad(Size)]. %% Build a correctly padded chunk (with a sub-header). @@ -409,7 +407,17 @@ encode_arg({atom, Atom}, Dict0) when is_atom(Atom) -> {Index, Dict} = beam_dict:atom(Atom, Dict0), {encode(?tag_a, Index), Dict}; encode_arg({integer, N}, Dict) -> - {encode(?tag_i, N), Dict}; + %% Conservatily assume that all integers whose absolute + %% value is greater than 1 bsl 128 will be bignums in + %% the runtime system. + if + N >= 1 bsl 128 -> + encode_arg({literal, N}, Dict); + N =< -(1 bsl 128) -> + encode_arg({literal, N}, Dict); + true -> + {encode(?tag_i, N), Dict} + end; encode_arg(nil, Dict) -> {encode(?tag_a, 0), Dict}; encode_arg({f, W}, Dict) -> diff --git a/lib/compiler/src/beam_block.erl b/lib/compiler/src/beam_block.erl index 6543e05e20..9543aa1355 100644 --- a/lib/compiler/src/beam_block.erl +++ b/lib/compiler/src/beam_block.erl @@ -23,30 +23,38 @@ -module(beam_block). -export([module/2]). --import(lists, [reverse/1,reverse/2,foldl/3,member/2]). +-import(lists, [reverse/1,reverse/2,member/2]). -spec module(beam_utils:module_code(), [compile:option()]) -> {'ok',beam_utils:module_code()}. -module({Mod,Exp,Attr,Fs0,Lc}, _Opt) -> - Fs = [function(F) || F <- Fs0], +module({Mod,Exp,Attr,Fs0,Lc}, Opts) -> + Blockify = not member(no_blockify, Opts), + Fs = [function(F, Blockify) || F <- Fs0], {ok,{Mod,Exp,Attr,Fs,Lc}}. -function({function,Name,Arity,CLabel,Is0}) -> +function({function,Name,Arity,CLabel,Is0}, Blockify) -> try %% Collect basic blocks and optimize them. - Is1 = blockify(Is0), - Is2 = embed_lines(Is1), - Is3 = move_allocates(Is2), - Is4 = beam_utils:live_opt(Is3), - Is5 = opt_blocks(Is4), - Is6 = beam_utils:delete_live_annos(Is5), - - %% Done. - {function,Name,Arity,CLabel,Is6} + Is2 = case Blockify of + true -> + Is1 = blockify(Is0), + embed_lines(Is1); + false -> + Is0 + end, + Is3 = local_cse(Is2), + Is4 = beam_utils:anno_defs(Is3), + Is5 = move_allocates(Is4), + Is6 = beam_utils:live_opt(Is5), + Is7 = opt_blocks(Is6), + Is8 = beam_utils:delete_annos(Is7), + Is = opt_allocs(Is8), + + %% Done. + {function,Name,Arity,CLabel,Is} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. @@ -102,7 +110,8 @@ collect({put_tuple,A,D}) -> {set,[D],[],{put_tuple,A}}; collect({put,S}) -> {set,[],[S],put}; collect({get_tuple_element,S,I,D}) -> {set,[D],[S],{get_tuple_element,I}}; collect({set_tuple_element,S,D,I}) -> {set,[],[S,D],{set_tuple_element,I}}; -collect({get_list,S,D1,D2}) -> {set,[D1,D2],[S],get_list}; +collect({get_hd,S,D}) -> {set,[D],[S],get_hd}; +collect({get_tl,S,D}) -> {set,[D],[S],get_tl}; collect(remove_message) -> {set,[],[],remove_message}; collect({put_map,F,Op,S,D,R,{list,Puts}}) -> {set,[D],[S|Puts],{alloc,R,{put_map,Op,F}}}; @@ -136,17 +145,16 @@ embed_lines([], Acc) -> Acc. opt_blocks([{block,Bl0}|Is]) -> %% The live annotation at the beginning is not useful. - [{'%live',_,_}|Bl] = Bl0, + [{'%anno',_}|Bl] = Bl0, [{block,opt_block(Bl)}|opt_blocks(Is)]; opt_blocks([I|Is]) -> [I|opt_blocks(Is)]; opt_blocks([]) -> []. opt_block(Is0) -> - Is = find_fixpoint(fun(Is) -> - opt_tuple_element(opt(Is)) - end, Is0), - opt_alloc(Is). + find_fixpoint(fun(Is) -> + opt_tuple_element(opt(Is)) + end, Is0). find_fixpoint(OptFun, Is0) -> case OptFun(Is0) of @@ -173,7 +181,7 @@ find_fixpoint(OptFun, Is0) -> %% safe to assume that if x(N) is initialized, then all lower-numbered %% x registers are also initialized. %% -%% For example, in general it is not safe to transform the following +%% For example, we must be careful when transforming the following %% instructions: %% %% get_tuple_element x(0) Element => x(1) @@ -185,13 +193,9 @@ find_fixpoint(OptFun, Is0) -> %% get_tuple_element x(0) Element => x(1) %% %% The transformation is safe if and only if x(1) has been -%% initialized previously. Unfortunately, beam_reorder may have moved -%% a get_tuple_element instruction so that x(1) is not always -%% initialized when this code is reached. To find whether or not x(1) -%% is initialized, we would need to analyze all code preceding these -%% two instructions (across branches). Since we currently don't have -%% any practical mechanism for doing that, we will have to -%% conservatively assume that the transformation is unsafe. +%% initialized previously. We will use the annotations added by +%% beam_utils:anno_defs/1 to determine whether x(a) has been +%% initialized. move_allocates([{block,Bl0}|Is]) -> Bl = move_allocates_1(reverse(Bl0), []), @@ -200,40 +204,69 @@ move_allocates([I|Is]) -> [I|move_allocates(Is)]; move_allocates([]) -> []. +move_allocates_1([{'%anno',_}|Is], Acc) -> + move_allocates_1(Is, Acc); move_allocates_1([I|Is], [{set,[],[],{alloc,Live0,Info}}|Acc]=Acc0) -> - case {alloc_may_pass(I),alloc_live_regs(I, Live0)} of - {false,_} -> - move_allocates_1(Is, [I|Acc0]); - {true,not_possible} -> - move_allocates_1(Is, [I|Acc0]); - {true,Live} when is_integer(Live) -> - A = {set,[],[],{alloc,Live,Info}}, - move_allocates_1(Is, [A,I|Acc]) + case alloc_may_pass(I) of + false -> + move_allocates_1(Is, [I|Acc0]); + true -> + case alloc_live_regs(I, Is, Live0) of + not_possible -> + move_allocates_1(Is, [I|Acc0]); + Live when is_integer(Live) -> + A = {set,[],[],{alloc,Live,Info}}, + move_allocates_1(Is, [A,I|Acc]) + end end; move_allocates_1([I|Is], Acc) -> move_allocates_1(Is, [I|Acc]); move_allocates_1([], Acc) -> Acc. +alloc_may_pass({set,_,[{fr,_}],fmove}) -> false; alloc_may_pass({set,_,_,{alloc,_,_}}) -> false; alloc_may_pass({set,_,_,{set_tuple_element,_}}) -> false; alloc_may_pass({set,_,_,put_list}) -> false; alloc_may_pass({set,_,_,put}) -> false; alloc_may_pass({set,_,_,_}) -> true. - + %% opt([Instruction]) -> [Instruction] %% Optimize the instruction stream inside a basic block. opt([{set,[X],[X],move}|Is]) -> opt(Is); +opt([{set,[Dst],_,move},{set,[Dst],[Src],move}=I|Is]) when Dst =/= Src -> + opt([I|Is]); +opt([{set,[{x,0}],[S1],move}=I1,{set,[D2],[{x,0}],move}|Is]) -> + opt([I1,{set,[D2],[S1],move}|Is]); +opt([{set,[{x,0}],[S1],move}=I1,{set,[D2],[S2],move}|Is0]) when S1 =/= D2 -> + %% Place move S x0 at the end of move sequences so that + %% loader can merge with the following instruction + {Ds,Is} = opt_moves([D2], Is0), + [{set,Ds,[S2],move}|opt([I1|Is])]; opt([{set,_,_,{line,_}}=Line1, {set,[D1],[{integer,Idx1},Reg],{bif,element,{f,0}}}=I1, {set,_,_,{line,_}}=Line2, {set,[D2],[{integer,Idx2},Reg],{bif,element,{f,0}}}=I2|Is]) when Idx1 < Idx2, D1 =/= D2, D1 =/= Reg, D2 =/= Reg -> opt([Line2,I2,Line1,I1|Is]); +opt([{set,[D1],[{integer,Idx1},Reg],{bif,element,{f,L}}}=I1, + {set,[D2],[{integer,Idx2},Reg],{bif,element,{f,L}}}=I2|Is]) + when Idx1 < Idx2, D1 =/= D2, D1 =/= Reg, D2 =/= Reg -> + opt([I2,I1|Is]); +opt([{set,Hd0,Cons,get_hd}=GetHd, + {set,Tl0,Cons,get_tl}=GetTl|Is0]) -> + case {opt_moves(Hd0, [GetTl|Is0]),opt_moves(Tl0, [GetHd|Is0])} of + {{Hd0,Is},{Tl0,_}} -> + [GetHd|opt(Is)]; + {{Hd,Is},{Tl0,_}} -> + [{set,Hd,Cons,get_hd}|opt(Is)]; + {{_,_},{Tl,Is}} -> + [{set,Tl,Cons,get_tl}|opt(Is)] + end; opt([{set,Ds0,Ss,Op}|Is0]) -> {Ds,Is} = opt_moves(Ds0, Is0), [{set,Ds,Ss,Op}|opt(Is)]; -opt([{'%live',_,_}=I|Is]) -> +opt([{'%anno',_}=I|Is]) -> [I|opt(Is)]; opt([]) -> []. @@ -245,17 +278,6 @@ opt_moves([D0]=Ds, Is0) -> case opt_move(D0, Is0) of not_possible -> {Ds,Is0}; {D1,Is} -> {[D1],Is} - end; -opt_moves([X0,Y0], Is0) -> - {X,Is2} = case opt_move(X0, Is0) of - not_possible -> {X0,Is0}; - {Y0,_} -> {X0,Is0}; - {_X1,_Is1} = XIs1 -> XIs1 - end, - case opt_move(Y0, Is2) of - not_possible -> {[X,Y0],Is2}; - {X,_} -> {[X,Y0],Is2}; - {Y,Is} -> {[X,Y],Is} end. %% opt_move(Dest, [Instruction]) -> {UpdatedDest,[Instruction]} | not_possible @@ -269,7 +291,7 @@ opt_move(Dest, Is) -> opt_move_1(R, [{set,[D],[R],move}|Is0], Acc) -> %% Provided that the source register is killed by instructions %% that follow, the optimization is safe. - case eliminate_use_of_from_reg(Is0, R, D, []) of + case eliminate_use_of_from_reg(Is0, R, D) of {yes,Is} -> opt_move_rev(D, Acc, Is); no -> not_possible end; @@ -327,7 +349,7 @@ opt_tuple_element_1([{set,_,_,{alloc,_,_}}|_], _, _, _) -> opt_tuple_element_1([{set,_,_,{try_catch,_,_}}|_], _, _, _) -> no; opt_tuple_element_1([{set,[D],[S],move}|Is0], I0, {_,S}, Acc) -> - case eliminate_use_of_from_reg(Is0, S, D, []) of + case eliminate_use_of_from_reg(Is0, S, D) of no -> no; {yes,Is} -> @@ -369,6 +391,14 @@ is_killed_or_used(R, {set,Ss,Ds,_}) -> %% that FromRegister is still used and that the optimization is not %% possible. +eliminate_use_of_from_reg(Is, From, To) -> + try + eliminate_use_of_from_reg(Is, From, To, []) + catch + throw:not_possible -> + no + end. + eliminate_use_of_from_reg([{set,_,_,{alloc,Live,_}}|_]=Is0, {x,X}, _, Acc) -> if X < Live -> @@ -377,21 +407,32 @@ eliminate_use_of_from_reg([{set,_,_,{alloc,Live,_}}|_]=Is0, {x,X}, _, Acc) -> {yes,reverse(Acc, Is0)} end; eliminate_use_of_from_reg([{set,Ds,Ss0,Op}=I0|Is], From, To, Acc) -> + ensure_safe_tuple(I0, To), I = case member(From, Ss0) of - true -> - Ss = [case S of - From -> To; - _ -> S - end || S <- Ss0], - {set,Ds,Ss,Op}; - false -> - I0 - end, + true -> + Ss = [case S of + From -> To; + _ -> S + end || S <- Ss0], + {set,Ds,Ss,Op}; + false -> + I0 + end, case member(From, Ds) of - true -> - {yes,reverse(Acc, [I|Is])}; - false -> - eliminate_use_of_from_reg(Is, From, To, [I|Acc]) + true -> + {yes,reverse(Acc, [I|Is])}; + false -> + case member(To, Ds) of + true -> + case beam_utils:is_killed_block(From, Is) of + true -> + {yes,reverse(Acc, [I|Is])}; + false -> + no + end; + false -> + eliminate_use_of_from_reg(Is, From, To, [I|Acc]) + end end; eliminate_use_of_from_reg([I]=Is, From, _To, Acc) -> case beam_utils:is_killed_block(From, [I]) of @@ -401,31 +442,51 @@ eliminate_use_of_from_reg([I]=Is, From, _To, Acc) -> no end. +ensure_safe_tuple({set,[To],[],{put_tuple,_}}, To) -> + throw(not_possible); +ensure_safe_tuple(_, _) -> ok. + +%% opt_allocs(Instructions) -> Instructions. Optimize allocate +%% instructions inside blocks. If safe, replace an allocate_zero +%% instruction with the slightly cheaper allocate instruction. + +opt_allocs(Is) -> + D = beam_utils:index_labels(Is), + opt_allocs_1(Is, D). + +opt_allocs_1([{block,Bl0}|Is], D) -> + Bl = opt_alloc(Bl0, {D,Is}), + [{block,Bl}|opt_allocs_1(Is, D)]; +opt_allocs_1([I|Is], D) -> + [I|opt_allocs_1(Is, D)]; +opt_allocs_1([], _) -> []. + %% opt_alloc(Instructions) -> Instructions' %% Optimises all allocate instructions. opt_alloc([{set,[],[],{alloc,Live0,Info0}}, - {set,[],[],{alloc,Live,Info}}|Is]) -> + {set,[],[],{alloc,Live,Info}}|Is], D) -> Live = Live0, %Assertion. Alloc = combine_alloc(Info0, Info), I = {set,[],[],{alloc,Live,Alloc}}, - opt_alloc([I|Is]); -opt_alloc([{set,[],[],{alloc,R,{_,Ns,Nh,[]}}}|Is]) -> - [{set,[],[],opt_alloc(Is, Ns, Nh, R)}|Is]; -opt_alloc([I|Is]) -> [I|opt_alloc(Is)]; -opt_alloc([]) -> []. + opt_alloc([I|Is], D); +opt_alloc([{set,[],[],{alloc,R,{_,Ns,Nh,[]}}}|Is], D) -> + [{set,[],[],opt_alloc(Is, D, Ns, Nh, R)}|Is]; +opt_alloc([I|Is], D) -> [I|opt_alloc(Is, D)]; +opt_alloc([], _) -> []. combine_alloc({_,Ns,Nh1,Init}, {_,nostack,Nh2,[]}) -> {zero,Ns,beam_utils:combine_heap_needs(Nh1, Nh2),Init}. - + %% opt_alloc(Instructions, FrameSize, HeapNeed, LivingRegs) -> [Instr] %% Generates the optimal sequence of instructions for %% allocating and initalizing the stack frame and needed heap. -opt_alloc(_Is, nostack, Nh, LivingRegs) -> +opt_alloc(_Is, _D, nostack, Nh, LivingRegs) -> {alloc,LivingRegs,{nozero,nostack,Nh,[]}}; -opt_alloc(Is, Ns, Nh, LivingRegs) -> - InitRegs = init_yreg(Is, 0), +opt_alloc(Bl, {D,OuterIs}, Ns, Nh, LivingRegs) -> + Is = [{block,Bl}|OuterIs], + InitRegs = init_yregs(Ns, Is, D), case count_ones(InitRegs) of N when N*2 > Ns -> {alloc,LivingRegs,{nozero,Ns,Nh,gen_init(Ns, InitRegs)}}; @@ -441,19 +502,14 @@ gen_init(Fs, Regs, Y, Acc) when Regs band 1 =:= 0 -> gen_init(Fs, Regs, Y, Acc) -> gen_init(Fs, Regs bsr 1, Y+1, Acc). -%% init_yreg(Instructions, RegSet) -> RegSetInitialized -%% Calculate the set of initialized y registers. - -init_yreg([{set,_,_,{bif,_,_}}|_], Reg) -> Reg; -init_yreg([{set,_,_,{alloc,_,{gc_bif,_,_}}}|_], Reg) -> Reg; -init_yreg([{set,_,_,{alloc,_,{put_map,_,_}}}|_], Reg) -> Reg; -init_yreg([{set,Ds,_,_}|Is], Reg) -> init_yreg(Is, add_yregs(Ds, Reg)); -init_yreg(_Is, Reg) -> Reg. - -add_yregs(Ys, Reg) -> foldl(fun(Y, R0) -> add_yreg(Y, R0) end, Reg, Ys). - -add_yreg({y,Y}, Reg) -> Reg bor (1 bsl Y); -add_yreg(_, Reg) -> Reg. +init_yregs(Y, Is, D) when Y >= 0 -> + case beam_utils:is_killed({y,Y}, Is, D) of + true -> + (1 bsl Y) bor init_yregs(Y-1, Is, D); + false -> + init_yregs(Y-1, Is, D) + end; +init_yregs(_, _, _) -> 0. count_ones(Bits) -> count_ones(Bits, 0). count_ones(0, Acc) -> Acc; @@ -463,16 +519,34 @@ count_ones(Bits, Acc) -> %% Calculate the new number of live registers when we move an allocate %% instruction upwards, passing a 'set' instruction. -alloc_live_regs({set,Ds,Ss,_}, Regs0) -> +alloc_live_regs({set,Ds,Ss,_}, Is, Regs0) -> Rset = x_live(Ss, x_dead(Ds, (1 bsl Regs0)-1)), - live_regs(0, Rset). + Live = live_regs(0, Rset), + case ensure_contiguous(Rset, Live) of + not_possible -> + %% Liveness information (looking forward in the + %% instruction stream) can't prove that moving this + %% allocation instruction is safe. Now use the annotation + %% of defined registers at the beginning of the current + %% block to see whether moving would be safe. + Def0 = defined_regs(Is, 0), + Def = Def0 band ((1 bsl Live) - 1), + ensure_contiguous(Rset bor Def, Live); + Live -> + %% Safe based on liveness information. + Live + end. live_regs(N, 0) -> N; -live_regs(N, Regs) when Regs band 1 =:= 1 -> - live_regs(N+1, Regs bsr 1); -live_regs(_, _) -> - not_possible. +live_regs(N, Regs) -> + live_regs(N+1, Regs bsr 1). + +ensure_contiguous(Regs, Live) -> + case (1 bsl Live) - 1 of + Regs -> Live; + _ -> not_possible + end. x_dead([{x,N}|Rs], Regs) -> x_dead(Rs, Regs band (bnot (1 bsl N))); x_dead([_|Rs], Regs) -> x_dead(Rs, Regs); @@ -481,3 +555,114 @@ x_dead([], Regs) -> Regs. x_live([{x,N}|Rs], Regs) -> x_live(Rs, Regs bor (1 bsl N)); x_live([_|Rs], Regs) -> x_live(Rs, Regs); x_live([], Regs) -> Regs. + +%% defined_regs(ReversedInstructions) -> RegBitmap. +%% Given a reversed instruction stream, determine the +%% the registers that are defined. + +defined_regs([{'%anno',{def,Def}}|_], Regs) -> + Def bor Regs; +defined_regs([{set,Ds,_,{alloc,Live,_}}|_], Regs) -> + x_live(Ds, Regs bor ((1 bsl Live) - 1)); +defined_regs([{set,Ds,_,_}|Is], Regs) -> + defined_regs(Is, x_live(Ds, Regs)). + +%%% +%%% Do local common sub expression elimination (CSE) in each block. +%%% + +local_cse([{block,Bl0}|Is]) -> + Bl = cse_block(Bl0, orddict:new(), []), + [{block,Bl}|local_cse(Is)]; +local_cse([I|Is]) -> + [I|local_cse(Is)]; +local_cse([]) -> []. + +cse_block([I|Is], Es0, Acc0) -> + Es1 = cse_clear(I, Es0), + case cse_expr(I) of + none -> + %% Instruction is not suitable for CSE. + cse_block(Is, Es1, [I|Acc0]); + {ok,D,Expr} -> + %% Suitable instruction. First update the dictionary of + %% suitable expressions for the next iteration. + Es = cse_add(D, Expr, Es1), + + %% Search for a previous identical expression. + case cse_find(Expr, Es0) of + error -> + %% Nothing found + cse_block(Is, Es, [I|Acc0]); + Src -> + %% Use the previously calculated result. + %% Also eliminate any line instruction. + Move = {set,[D],[Src],move}, + case Acc0 of + [{set,_,_,{line,_}}|Acc] -> + cse_block(Is, Es, [Move|Acc]); + [_|_] -> + cse_block(Is, Es, [Move|Acc0]) + end + end + end; +cse_block([], _, Acc) -> + reverse(Acc). + +%% cse_find(Expr, Expressions) -> error | Register. +%% Find a previously evaluated expression whose result can be reused, +%% or return 'error' if no such expression is found. + +cse_find(Expr, Es) -> + case orddict:find(Expr, Es) of + {ok,{Src,_}} -> Src; + error -> error + end. + +cse_expr({set,[D],Ss,{bif,N,_}}) -> + {ok,D,{{bif,N},Ss}}; +cse_expr({set,[D],Ss,{alloc,_,{gc_bif,N,_}}}) -> + {ok,D,{{gc_bif,N},Ss}}; +cse_expr({set,[D],Ss,put_list}) -> + {ok,D,{put_list,Ss}}; +cse_expr(_) -> none. + +%% cse_clear(Instr, Expressions0) -> Expressions. +%% Remove all previous expressions that will become +%% invalid when this instruction is executed. Basically, +%% an expression is no longer safe to reuse when the +%% register it has been stored to has been modified, killed, +%% or if any of the source operands have changed. + +cse_clear({set,Ds,_,{alloc,Live,_}}, Es) -> + cse_clear_1(Es, Live, Ds); +cse_clear({set,Ds,_,_}, Es) -> + cse_clear_1(Es, all, Ds). + +cse_clear_1(Es, Live, Ds0) -> + Ds = ordsets:from_list(Ds0), + [E || E <- Es, cse_is_safe(E, Live, Ds)]. + +cse_is_safe({_,{Dst,Interfering}}, Live, Ds) -> + ordsets:is_disjoint(Interfering, Ds) andalso + case Dst of + {x,X} -> + X < Live; + _ -> + true + end. + +%% cse_add(Dest, Expr, Expressions0) -> Expressions. +%% Provided that it is safe, add a new expression to the dictionary +%% of already evaluated expressions. + +cse_add(D, {_,Ss}=Expr, Es) -> + case member(D, Ss) of + false -> + Interfering = ordsets:from_list([D|Ss]), + orddict:store(Expr, {D,Interfering}, Es); + true -> + %% Unsafe because the instruction overwrites one of + %% source operands. + Es + end. diff --git a/lib/compiler/src/beam_bs.erl b/lib/compiler/src/beam_bs.erl index beb055b23d..14cedbb582 100644 --- a/lib/compiler/src/beam_bs.erl +++ b/lib/compiler/src/beam_bs.erl @@ -38,8 +38,7 @@ function({function,Name,Arity,CLabel,Is0}, Lc0) -> {Is,Lc} = bsm_opt(Is1, Lc0), {{function,Name,Arity,CLabel,Is},Lc} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. diff --git a/lib/compiler/src/beam_bsm.erl b/lib/compiler/src/beam_bsm.erl index 9a4e7fb133..9f3b9d788f 100644 --- a/lib/compiler/src/beam_bsm.erl +++ b/lib/compiler/src/beam_bsm.erl @@ -105,8 +105,7 @@ function({function,Name,Arity,Entry,Is}, FIndex) -> D = #btb{f=FIndex,index=Index}, {function,Name,Arity,Entry,btb_opt_1(Is, D, [])} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. @@ -125,20 +124,21 @@ btb_opt_1([{test,bs_get_binary2,F,_,[Reg,{atom,all},U,Fs],Reg}=I0|Is], D, Acc0) end, btb_opt_1(Is, D, Acc) end; -btb_opt_1([{test,bs_get_binary2,F,_,[Ctx,{atom,all},U,Fs],Dst}=I0|Is], D, Acc0) -> - case btb_reaches_match(Is, [Ctx,Dst], D) of +btb_opt_1([{test,bs_get_binary2,F,_,[Ctx,{atom,all},U,Fs],Dst}=I0|Is0], D, Acc0) -> + case btb_reaches_match(Is0, [Ctx,Dst], D) of {error,Reason} -> Comment = btb_comment_no_opt(Reason, Fs), - btb_opt_1(Is, D, [Comment,I0|Acc0]); + btb_opt_1(Is0, D, [Comment,I0|Acc0]); {ok,MustSave} when U =:= 1 -> Comment = btb_comment_opt(Fs), - Acc1 = btb_gen_save(MustSave, Ctx, [Comment|Acc0]), - Acc = [{move,Ctx,Dst}|Acc1], + Acc = btb_gen_save(MustSave, Ctx, [Comment|Acc0]), + Is = prepend_move(Ctx, Dst, Is0), btb_opt_1(Is, D, Acc); {ok,MustSave} -> Comment = btb_comment_opt(Fs), Acc1 = btb_gen_save(MustSave, Ctx, [Comment|Acc0]), - Acc = [{move,Ctx,Dst},{test,bs_test_unit,F,[Ctx,U]}|Acc1], + Acc = [{test,bs_test_unit,F,[Ctx,U]}|Acc1], + Is = prepend_move(Ctx, Dst, Is0), btb_opt_1(Is, D, Acc) end; btb_opt_1([I|Is], D, Acc) -> @@ -151,6 +151,12 @@ btb_gen_save(true, Reg, Acc) -> [{bs_save2,Reg,{atom,start}}|Acc]; btb_gen_save(false, _, Acc) -> Acc. +prepend_move(Ctx, Dst, [{block,Bl0}|Is]) -> + Bl = [{set,[Dst],[Ctx],move}|Bl0], + [{block,Bl}|Is]; +prepend_move(Ctx, Dst, Is) -> + [{move,Ctx,Dst}|Is]. + %% btb_reaches_match([Instruction], [Register], D) -> %% {ok,MustSave}|{error,Reason} %% diff --git a/lib/compiler/src/beam_dead.erl b/lib/compiler/src/beam_dead.erl index d379fdc4eb..dbbaae05eb 100644 --- a/lib/compiler/src/beam_dead.erl +++ b/lib/compiler/src/beam_dead.erl @@ -56,8 +56,7 @@ function({function,Name,Arity,CLabel,Is0}, Lc0) -> Is = move_move_into_block(Is3, []), {{function,Name,Arity,CLabel,Is},Lc} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. @@ -272,7 +271,8 @@ backward([{jump,{f,To0}},{move,Src,Reg}=Move|Is], D, Acc) -> end; backward([{jump,{f,To}}=J|[{bif,Op,{f,BifFail},Ops,Reg}|Is]=Is0], D, Acc) -> try replace_comp_op(To, Reg, Op, Ops, D) of - I -> backward(Is, D, I++Acc) + {Test,Jump} -> + backward([Jump,Test|Is], D, Acc) catch throw:not_possible -> case To =:= BifFail of @@ -294,24 +294,25 @@ backward([{jump,{f,To}}=J|[{gc_bif,_,{f,To},_,_,_Dst}|Is]], D, Acc) -> %% register is initialized, and it is therefore no need to test %% for liveness of the destination register at label To. backward([J|Is], D, Acc); -backward([{test,bs_start_match2,F,Live,[R,_]=Args,Ctxt}|Is], D, - [{test,bs_match_string,F,[Ctxt,Bs]}, - {test,bs_test_tail2,F,[Ctxt,0]}|Acc0]=Acc) -> +backward([{test,bs_start_match2,F,Live,[Src,_]=Args,Ctxt}|Is], D, Acc0) -> {f,To0} = F, - case beam_utils:is_killed(Ctxt, Acc0, D) of - true -> - To = shortcut_bs_context_to_binary(To0, R, D), - Eq = {test,is_eq_exact,{f,To},[R,{literal,Bs}]}, - backward(Is, D, [Eq|Acc0]); - false -> - To = shortcut_bs_start_match(To0, R, D), - I = {test,bs_start_match2,{f,To},Live,Args,Ctxt}, - backward(Is, D, [I|Acc]) + case test_bs_literal(F, Ctxt, D, Acc0) of + {none,Acc} -> + %% Ctxt killed immediately after bs_start_match2. + To = shortcut_bs_context_to_binary(To0, Src, D), + I = {test,is_bitstr,{f,To},[Src]}, + backward(Is, D, [I|Acc]); + {Literal,Acc} -> + %% Ctxt killed after matching a literal. + To = shortcut_bs_context_to_binary(To0, Src, D), + Eq = {test,is_eq_exact,{f,To},[Src,{literal,Literal}]}, + backward(Is, D, [Eq|Acc]); + not_killed -> + %% Ctxt not killed. Not much to do. + To = shortcut_bs_start_match(To0, Src, D), + I = {test,bs_start_match2,{f,To},Live,Args,Ctxt}, + backward(Is, D, [I|Acc0]) end; -backward([{test,bs_start_match2,{f,To0},Live,[Src|_]=Info,Dst}|Is], D, Acc) -> - To = shortcut_bs_start_match(To0, Src, D), - I = {test,bs_start_match2,{f,To},Live,Info,Dst}, - backward(Is, D, [I|Acc]); backward([{test,Op,{f,To0},Ops0}|Is], D, Acc) -> To1 = shortcut_bs_test(To0, Is, D), To2 = shortcut_label(To1, D), @@ -446,7 +447,7 @@ prune_redundant([], _) -> []. replace_comp_op(To, Reg, Op, Ops, D) -> False = comp_op_find_shortcut(To, Reg, {atom,false}, D), True = comp_op_find_shortcut(To, Reg, {atom,true}, D), - [bif_to_test(Op, Ops, False),{jump,{f,True}}]. + {bif_to_test(Op, Ops, False),{jump,{f,True}}}. comp_op_find_shortcut(To0, Reg, Val, D) -> case shortcut_select_label(To0, Reg, Val, D) of @@ -483,15 +484,22 @@ not_possible() -> throw(not_possible). %% F1: is_eq_exact F2 Reg Lit2 F1: is_eq_exact F2 Reg Lit2 %% L2: .... L2: %% -combine_eqs(To, [Reg,{Type,_}=Lit1]=Ops, D, [{label,L1}|_]) - when Type =:= atom; Type =:= integer -> +combine_eqs(To, [Reg,{Type,_}=Lit1]=Ops, D, Acc) + when Type =:= atom; Type =:= integer -> + Next = case Acc of + [{label,Lbl}|_] -> Lbl; + [{jump,{f,Lbl}}|_] -> Lbl + end, case beam_utils:code_at(To, D) of [{test,is_eq_exact,{f,F2},[Reg,{Type,_}=Lit2]}, {label,L2}|_] when Lit1 =/= Lit2 -> - {select,select_val,Reg,{f,F2},[Lit1,{f,L1},Lit2,{f,L2}]}; + {select,select_val,Reg,{f,F2},[Lit1,{f,Next},Lit2,{f,L2}]}; + [{test,is_eq_exact,{f,F2},[Reg,{Type,_}=Lit2]}, + {jump,{f,L2}}|_] when Lit1 =/= Lit2 -> + {select,select_val,Reg,{f,F2},[Lit1,{f,Next},Lit2,{f,L2}]}; [{select,select_val,Reg,{f,F2},[{Type,_}|_]=List0}|_] -> List = remove_from_list(Lit1, List0), - {select,select_val,Reg,{f,F2},[Lit1,{f,L1}|List]}; + {select,select_val,Reg,{f,F2},[Lit1,{f,Next}|List]}; _Is -> {test,is_eq_exact,{f,To},Ops} end; @@ -504,6 +512,22 @@ remove_from_list(Lit, [Val,{f,_}=Fail|T]) -> [Val,Fail|remove_from_list(Lit, T)]; remove_from_list(_, []) -> []. + +test_bs_literal(F, Ctxt, D, + [{test,bs_match_string,F,[Ctxt,Bs]}, + {test,bs_test_tail2,F,[Ctxt,0]}|Acc]) -> + test_bs_literal_1(Ctxt, Acc, D, Bs); +test_bs_literal(F, Ctxt, D, [{test,bs_test_tail2,F,[Ctxt,0]}|Acc]) -> + test_bs_literal_1(Ctxt, Acc, D, <<>>); +test_bs_literal(_, Ctxt, D, Acc) -> + test_bs_literal_1(Ctxt, Acc, D, none). + +test_bs_literal_1(Ctxt, Is, D, Literal) -> + case beam_utils:is_killed(Ctxt, Is, D) of + true -> {Literal,Is}; + false -> not_killed + end. + %% shortcut_bs_test(TargetLabel, ReversedInstructions, D) -> TargetLabel' %% Try to shortcut the failure label for bit syntax matching. diff --git a/lib/compiler/src/beam_disasm.erl b/lib/compiler/src/beam_disasm.erl index 8fd0b36d05..a68c4b5367 100644 --- a/lib/compiler/src/beam_disasm.erl +++ b/lib/compiler/src/beam_disasm.erl @@ -163,8 +163,8 @@ pp_instr(I) -> file(File) -> try process_chunks(File) - catch error:Reason -> - {error,?MODULE,{internal,{Reason,erlang:get_stacktrace()}}} + catch error:Reason:Stack -> + {error,?MODULE,{internal,{Reason,Stack}}} end. %%----------------------------------------------------------------------- @@ -719,42 +719,6 @@ resolve_inst({wait,[Lbl]},_,_,_) -> {wait,Lbl}; resolve_inst({wait_timeout,[Lbl,Int]},_,_,_) -> {wait_timeout,Lbl,resolve_arg(Int)}; -resolve_inst({m_plus,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'+',W,[SrcR1,SrcR2],DstR}; -resolve_inst({m_minus,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'-',W,[SrcR1,SrcR2],DstR}; -resolve_inst({m_times,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'*',W,[SrcR1,SrcR2],DstR}; -resolve_inst({m_div,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'/',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_div,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'div',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_rem,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'rem',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_band,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'band',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_bor,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'bor',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_bxor,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'bxor',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_bsl,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'bsl',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_bsr,Args},_,_,_) -> - [W,SrcR1,SrcR2,DstR] = resolve_args(Args), - {arithbif,'bsr',W,[SrcR1,SrcR2],DstR}; -resolve_inst({int_bnot,Args},_,_,_) -> - [W,SrcR,DstR] = resolve_args(Args), - {arithbif,'bnot',W,[SrcR],DstR}; resolve_inst({is_lt=I,Args0},_,_,_) -> [L|Args] = resolve_args(Args0), {test,I,L,Args}; @@ -800,9 +764,6 @@ resolve_inst({is_nil=I,Args0},_,_,_) -> resolve_inst({is_binary=I,Args0},_,_,_) -> [L|Args] = resolve_args(Args0), {test,I,L,Args}; -resolve_inst({is_constant=I,Args0},_,_,_) -> - [L|Args] = resolve_args(Args0), - {test,I,L,Args}; resolve_inst({is_list=I,Args0},_,_,_) -> [L|Args] = resolve_args(Args0), {test,I,L,Args}; @@ -840,11 +801,6 @@ resolve_inst({get_tuple_element,[Src,{u,Off},Dst]},_,_,_) -> {get_tuple_element,resolve_arg(Src),Off,resolve_arg(Dst)}; resolve_inst({set_tuple_element,[Src,Dst,{u,Off}]},_,_,_) -> {set_tuple_element,resolve_arg(Src),resolve_arg(Dst),Off}; -resolve_inst({put_string,[{u,Len},{u,Off},Dst]},_,Strings,_) -> - String = if Len > 0 -> binary_to_list(Strings, Off+1, Off+Len); - true -> "" - end, - {put_string,Len,{string,String},Dst}; resolve_inst({put_list,[Src1,Src2,Dst]},_,_,_) -> {put_list,resolve_arg(Src1),resolve_arg(Src2),Dst}; resolve_inst({put_tuple,[{u,Arity},Dst]},_,_,_) -> @@ -859,9 +815,6 @@ resolve_inst({case_end,[X]},_,_,_) -> {case_end,resolve_arg(X)}; resolve_inst({call_fun,[{u,N}]},_,_,_) -> {call_fun,N}; -resolve_inst({make_fun,Args},_,_,Lbls) -> - [{f,L},Magic,FreeVars] = resolve_args(Args), - {make_fun,lookup(L,Lbls),Magic,FreeVars}; resolve_inst({is_function=I,Args0},_,_,_) -> [L|Args] = resolve_args(Args0), {test,I,L,Args}; @@ -870,30 +823,6 @@ resolve_inst({call_ext_only,[{u,N},{u,MFAix}]},Imports,_,_) -> %% %% Instructions for handling binaries added in R7A & R7B %% -resolve_inst({bs_start_match,[F,Reg]},_,_,_) -> - {bs_start_match,F,Reg}; -resolve_inst({bs_get_integer=I,[Lbl,Arg2,{u,N},{u,U},Arg5]},_,_,_) -> - [A2,A5] = resolve_args([Arg2,Arg5]), - {test,I,Lbl,[A2,N,decode_field_flags(U),A5]}; -resolve_inst({bs_get_float=I,[Lbl,Arg2,{u,N},{u,U},Arg5]},_,_,_) -> - [A2,A5] = resolve_args([Arg2,Arg5]), - {test,I,Lbl,[A2,N,decode_field_flags(U),A5]}; -resolve_inst({bs_get_binary=I,[Lbl,Arg2,{u,N},{u,U},Arg5]},_,_,_) -> - [A2,A5] = resolve_args([Arg2,Arg5]), - {test,I,Lbl,[A2,N,decode_field_flags(U),A5]}; -resolve_inst({bs_skip_bits,[Lbl,Arg2,{u,N},{u,U}]},_,_,_) -> - A2 = resolve_arg(Arg2), - {test,bs_skip_bits,Lbl,[A2,N,decode_field_flags(U)]}; -resolve_inst({bs_test_tail,[F,{u,N}]},_,_,_) -> - {test,bs_test_tail,F,[N]}; -resolve_inst({bs_save,[{u,N}]},_,_,_) -> - {bs_save,N}; -resolve_inst({bs_restore,[{u,N}]},_,_,_) -> - {bs_restore,N}; -resolve_inst({bs_init,[{u,N},{u,U}]},_,_,_) -> - {bs_init,N,decode_field_flags(U)}; -resolve_inst({bs_final,[F,X]},_,_,_) -> - {bs_final,F,X}; resolve_inst({bs_put_integer,[Lbl,Arg2,{u,N},{u,U},Arg5]},_,_,_) -> [A2,A5] = resolve_args([Arg2,Arg5]), {bs_put_integer,Lbl,A2,N,decode_field_flags(U),A5}; @@ -908,8 +837,6 @@ resolve_inst({bs_put_string,[{u,Len},{u,Off}]},_,Strings,_) -> true -> "" end, {bs_put_string,Len,{string,String}}; -resolve_inst({bs_need_buf,[{u,N}]},_,_,_) -> - {bs_need_buf,N}; %% %% Instructions for handling floating point numbers added in June 2001 (R8). @@ -961,9 +888,6 @@ resolve_inst({raise,[_Reg1,_Reg2]=Regs},_,_,_) -> resolve_inst({bs_init2,[Lbl,Arg2,{u,W},{u,R},{u,F},Arg6]},_,_,_) -> [A2,A6] = resolve_args([Arg2,Arg6]), {bs_init2,Lbl,A2,W,R,decode_field_flags(F),A6}; -resolve_inst({bs_bits_to_bytes,[Lbl,Arg2,Arg3]},_,_,_) -> - [A2,A3] = resolve_args([Arg2,Arg3]), - {bs_bits_to_bytes,Lbl,A2,A3}; resolve_inst({bs_add=I,[Lbl,Arg2,Arg3,Arg4,Arg5]},_,_,_) -> [A2,A3,A4,A5] = resolve_args([Arg2,Arg3,Arg4,Arg5]), {I,Lbl,[A2,A3,A4],A5}; @@ -1041,12 +965,6 @@ resolve_inst({gc_bif3,Args},Imports,_,_) -> {gc_bif,BifName,F,Live,[A1,A2,A3],Reg}; %% -%% New instructions for creating non-byte aligned binaries. -%% -resolve_inst({bs_final2,[X,Y]},_,_,_) -> - {bs_final2,X,Y}; - -%% %% R11B-5. %% resolve_inst({is_bitstr=I,Args0},_,_,_) -> @@ -1165,6 +1083,19 @@ resolve_inst({get_map_elements,Args0},_,_,_) -> {get_map_elements,FLbl,Src,{list,List}}; %% +%% OTP 21. +%% + +resolve_inst({build_stacktrace,[]},_,_,_) -> + build_stacktrace; +resolve_inst({raw_raise,[]},_,_,_) -> + raw_raise; +resolve_inst({get_hd,[Src,Dst]},_,_,_) -> + {get_hd,Src,Dst}; +resolve_inst({get_tl,[Src,Dst]},_,_,_) -> + {get_tl,Src,Dst}; + +%% %% Catches instructions that are not yet handled. %% resolve_inst(X,_,_,_) -> ?exit({resolve_inst,X}). diff --git a/lib/compiler/src/beam_disasm.hrl b/lib/compiler/src/beam_disasm.hrl index d968cd9587..c3326c15a0 100644 --- a/lib/compiler/src/beam_disasm.hrl +++ b/lib/compiler/src/beam_disasm.hrl @@ -26,7 +26,8 @@ %% IT SHOULD BE MOVED TO A FILE THAT DEFINES (AND EXPORTS) %% PROPER TYPES FOR THE SET OF BEAM INSTRUCTIONS. %% --type beam_instr() :: 'bs_init_writable' | 'fclearerror' | 'if_end' +-type beam_instr() :: 'bs_init_writable' | 'build_stacktrace' + | 'fclearerror' | 'if_end' | 'raw_raise' | 'remove_message' | 'return' | 'send' | 'timeout' | tuple(). %% XXX: Very underspecified - FIX THIS diff --git a/lib/compiler/src/beam_except.erl b/lib/compiler/src/beam_except.erl index 9801c68ee2..abd39c661d 100644 --- a/lib/compiler/src/beam_except.erl +++ b/lib/compiler/src/beam_except.erl @@ -45,8 +45,7 @@ function({function,Name,Arity,CLabel,Is0}) -> Is = function_1(Is0), {function,Name,Arity,CLabel,Is} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. diff --git a/lib/compiler/src/beam_flatten.erl b/lib/compiler/src/beam_flatten.erl index a4d45a4ca6..4045ab6dc5 100644 --- a/lib/compiler/src/beam_flatten.erl +++ b/lib/compiler/src/beam_flatten.erl @@ -50,6 +50,9 @@ norm_block([{set,[],[],{alloc,R,Alloc}}|Is], Acc0) -> Acc -> norm_block(Is, Acc) end; +norm_block([{set,[D1],[S],get_hd},{set,[D2],[S],get_tl}|Is], Acc) -> + I = {get_list,S,D1,D2}, + norm_block(Is, [I|Acc]); norm_block([I|Is], Acc) -> norm_block(Is, [norm(I)|Acc]); norm_block([], Acc) -> Acc. @@ -64,7 +67,8 @@ norm({set,[D],[],{put_tuple,A}}) -> {put_tuple,A,D}; norm({set,[],[S],put}) -> {put,S}; norm({set,[D],[S],{get_tuple_element,I}}) -> {get_tuple_element,S,I,D}; norm({set,[],[S,D],{set_tuple_element,I}}) -> {set_tuple_element,S,D,I}; -norm({set,[D1,D2],[S],get_list}) -> {get_list,S,D1,D2}; +norm({set,[D],[S],get_hd}) -> {get_hd,S,D}; +norm({set,[D],[S],get_tl}) -> {get_tl,S,D}; norm({set,[D],[S|Puts],{alloc,R,{put_map,Op,F}}}) -> {put_map,F,Op,S,D,R,{list,Puts}}; norm({set,[],[],remove_message}) -> remove_message; diff --git a/lib/compiler/src/beam_jump.erl b/lib/compiler/src/beam_jump.erl index 0bcec9ce19..c33de217bd 100644 --- a/lib/compiler/src/beam_jump.erl +++ b/lib/compiler/src/beam_jump.erl @@ -336,17 +336,6 @@ opt([{test,_,{f,L}=Lbl,_}=I|[{label,L}|_]=Is], Acc0, St0) -> {Acc,St} = opt_useless_loads(Acc0, L, St0), opt(Is, Acc, St) end; -opt([{test,_,{f,L}=Lbl,_}=I|[{label,L}|_]=Is], Acc0, St0) -> - %% Similar to the above, except we have a fall-through rather than jump - %% Test Label Ops - %% label Label - case beam_utils:is_pure_test(I) of - false -> - opt(Is, [I|Acc0], label_used(Lbl, St0)); - true -> - {Acc,St} = opt_useless_loads(Acc0, L, St0), - opt(Is, Acc, St) - end; opt([{test,Test0,{f,L}=Lbl,Ops}=I|[{jump,To}|Is]=Is0], Acc, St) -> case is_label_defined(Is, L) of false -> diff --git a/lib/compiler/src/beam_listing.erl b/lib/compiler/src/beam_listing.erl index 94b47cf568..73c6501fe5 100644 --- a/lib/compiler/src/beam_listing.erl +++ b/lib/compiler/src/beam_listing.erl @@ -23,14 +23,13 @@ -include("core_parse.hrl"). -include("v3_kernel.hrl"). --include("v3_life.hrl"). +-include("beam_disasm.hrl"). -import(lists, [foreach/2]). -type code() :: cerl:c_module() | beam_utils:module_code() | #k_mdef{} - | {module(),_,_,_} %v3_life | [_]. %form-based format -spec module(file:io_device(), code()) -> 'ok'. @@ -42,13 +41,9 @@ module(File, #k_mdef{}=Kern) -> %% This is a kernel module. io:put_chars(File, v3_kernel_pp:format(Kern)); %%io:put_chars(File, io_lib:format("~p~n", [Kern])); -module(File, {Mod,Exp,Attr,Kern}) -> - %% This is output from beam_life (v3). - io:fwrite(File, "~w.~n~p.~n~p.~n", [Mod,Exp,Attr]), - foreach(fun (F) -> function(File, F) end, Kern); module(Stream, {Mod,Exp,Attr,Code,NumLabels}) -> - %% This is output from beam_codegen. - io:format(Stream, "{module, ~p}. %% version = ~w\n", + %% This is output from v3_codegen. + io:format(Stream, "{module, ~p}. %% version = ~w\n", [Mod, beam_opcodes:format_number()]), io:format(Stream, "\n{exports, ~p}.\n", [Exp]), io:format(Stream, "\n{attributes, ~p}.\n", [Attr]), @@ -68,60 +63,3 @@ format_asm([{label,L}|Is]) -> format_asm([I|Is]) -> [io_lib:format(" ~p", [I]),".\n"|format_asm(Is)]; format_asm([]) -> []. - -function(File, {function,Name,Arity,Args,Body,Vdb,_Anno}) -> - io:nl(File), - io:format(File, "function ~p/~p.\n", [Name,Arity]), - io:format(File, " ~p.\n", [Args]), - print_vdb(File, Vdb), - put(beam_listing_nl, false), - nl(File), - foreach(fun(F) -> format(File, F, []) end, Body), - nl(File), - erase(beam_listing_nl). - -format(File, #l{ke=Ke,i=I,vdb=Vdb}, Ind) -> - nl(File), - ind_format(File, Ind, "~p ", [I]), - print_vdb(File, Vdb), - nl(File), - format(File, Ke, Ind); -format(File, Tuple, Ind) when is_tuple(Tuple) -> - ind_format(File, Ind, "{", []), - format_list(File, tuple_to_list(Tuple), [$\s|Ind]), - ind_format(File, Ind, "}", []); -format(File, List, Ind) when is_list(List) -> - ind_format(File, Ind, "[", []), - format_list(File, List, [$\s|Ind]), - ind_format(File, Ind, "]", []); -format(File, F, Ind) -> - ind_format(File, Ind, "~p", [F]). - -format_list(File, [F], Ind) -> - format(File, F, Ind); -format_list(File, [F|Fs], Ind) -> - format(File, F, Ind), - ind_format(File, Ind, ",", []), - format_list(File, Fs, Ind); -format_list(_, [], _) -> ok. - - -print_vdb(File, [{Var,F,E}|Vs]) -> - io:format(File, "~p:~p..~p ", [Var,F,E]), - print_vdb(File, Vs); -print_vdb(_, []) -> ok. - -ind_format(File, Ind, Format, Args) -> - case get(beam_listing_nl) of - true -> - put(beam_listing_nl, false), - io:put_chars(File, Ind); - false -> ok - end, - io:format(File, Format, Args). - -nl(File) -> - case put(beam_listing_nl, true) of - true -> ok; - false -> io:nl(File) - end. diff --git a/lib/compiler/src/beam_peep.erl b/lib/compiler/src/beam_peep.erl index 9436c20b36..eb3192fe8f 100644 --- a/lib/compiler/src/beam_peep.erl +++ b/lib/compiler/src/beam_peep.erl @@ -41,8 +41,7 @@ function({function,Name,Arity,CLabel,Is0}) -> Is = beam_jump:remove_unused_labels(Is1), {function,Name,Arity,CLabel,Is} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. diff --git a/lib/compiler/src/beam_receive.erl b/lib/compiler/src/beam_receive.erl index 468460eedf..3c8efa577c 100644 --- a/lib/compiler/src/beam_receive.erl +++ b/lib/compiler/src/beam_receive.erl @@ -82,8 +82,7 @@ function({function,Name,Arity,Entry,Is}) -> D = beam_utils:index_labels(Is), {function,Name,Arity,Entry,opt(Is, D, [])} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. diff --git a/lib/compiler/src/beam_record.erl b/lib/compiler/src/beam_record.erl index 419089b1bc..58a6de6775 100644 --- a/lib/compiler/src/beam_record.erl +++ b/lib/compiler/src/beam_record.erl @@ -15,19 +15,12 @@ %% %% %CopyrightEnd% %% -%% File: beam_record.erl -%% Author: Björn-Egil Dahlberg -%% Created: 2014-09-03 -%% - --module(beam_record). --export([module/2]). %% Rewrite the instruction stream on tagged tuple tests. -%% Tagged tuples means a tuple of any arity with an atom as its first element. -%% Typically records, ok-tuples and error-tuples. -%% -%% from: +%% Tagged tuples means a tuple of any arity with an atom as its +%% first element, such as records and error tuples. +%% +%% From: %% ... %% {test,is_tuple,Fail,[Src]}. %% {test,test_arity,Fail,[Src,Sz]}. @@ -36,13 +29,16 @@ %% ... %% {test,is_eq_exact,Fail,[Dst,Atom]}. %% ... -%% to: +%% To: %% ... %% {test,is_tagged_tuple,Fail,[Src,Sz,Atom]}. %% ... +%% +-module(beam_record). +-export([module/2]). --import(lists, [reverse/1]). +-import(lists, [reverse/1,reverse/2]). -spec module(beam_utils:module_code(), [compile:option()]) -> {'ok',beam_utils:module_code()}. @@ -51,56 +47,85 @@ module({Mod,Exp,Attr,Fs0,Lc}, _Opt) -> Fs = [function(F) || F <- Fs0], {ok,{Mod,Exp,Attr,Fs,Lc}}. -function({function,Name,Arity,CLabel,Is}) -> +function({function,Name,Arity,CLabel,Is0}) -> try - Idx = beam_utils:index_labels(Is), - {function,Name,Arity,CLabel,rewrite(Is,Idx)} + Is1 = beam_utils:anno_defs(Is0), + Idx = beam_utils:index_labels(Is1), + Is = rewrite(reverse(Is1), Idx), + {function,Name,Arity,CLabel,Is} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. -rewrite(Is,Idx) -> - rewrite(Is,Idx,[]). +rewrite(Is, Idx) -> + rewrite(Is, Idx, 0, []). -rewrite([{test,is_tuple,Fail,[Src]}=I1, - {test,test_arity,Fail,[Src,N]}=I2|Is],Idx,Acc) -> - case is_tagged_tuple(Is,Fail,Src,Idx) of +rewrite([{test,test_arity,Fail,[Src,N]}=TA, + {test,is_tuple,Fail,[Src]}=TT|Is], Idx, Def, Acc0) -> + case is_tagged_tuple(Acc0, Def, Fail, Src, Idx) of no -> - rewrite(Is,Idx,[I2,I1|Acc]); - {Atom,[{block,[]}|Is1]} -> - rewrite(Is1,Idx,[{test,is_tagged_tuple,Fail,[Src,N,Atom]}|Acc]); - {Atom,Is1} -> - rewrite(Is1,Idx,[{test,is_tagged_tuple,Fail,[Src,N,Atom]}|Acc]) + rewrite(Is, Idx, 0, [TT,TA|Acc0]); + {yes,Atom,Acc} -> + I = {test,is_tagged_tuple,Fail,[Src,N,Atom]}, + rewrite(Is, Idx, Def, [I|Acc]) end; -rewrite([I|Is],Idx,Acc) -> - rewrite(Is,Idx,[I|Acc]); -rewrite([],_,Acc) -> reverse(Acc). - -is_tagged_tuple([{block,[{set,[Dst],[Src],{get_tuple_element,0}}=B|Bs]}, - {test,is_eq_exact,Fail,[Dst,{atom,_}=Atom]}|Is],Fail,Src,Idx) -> +rewrite([{block,[{'%anno',{def,Def}}|Bl]}|Is], Idx, _Def, Acc) -> + rewrite(Is, Idx, Def, [{block,Bl}|Acc]); +rewrite([{label,L}=I|Is], Idx0, Def, Acc) -> + Idx = beam_utils:index_label(L, Acc, Idx0), + rewrite(Is, Idx, Def, [I|Acc]); +rewrite([I|Is], Idx, Def, Acc) -> + rewrite(Is, Idx, Def, [I|Acc]); +rewrite([], _, _, Acc) -> Acc. - %% if Dst is killed in the instruction stream and at fail label, - %% we can safely remove get_tuple_element. - %% - %% if Dst is not killed in the stream, we cannot remove get_tuple_element - %% since it is referenced. - - case is_killed(Dst,Is,Fail,Idx) of - true -> {Atom,[{block,Bs}|Is]}; - false -> {Atom,[{block,[B|Bs]}|Is]} +is_tagged_tuple([{block,Bl}, + {test,is_eq_exact,Fail,[Dst,{atom,_}=Atom]}|Is], + Def, Fail, Src, Idx) -> + case is_tagged_tuple_1(Bl, Is, Fail, Src, Dst, Idx, Def, []) of + no -> + no; + {yes,[]} -> + {yes,Atom,Is}; + {yes,[_|_]=Block} -> + {yes,Atom,[{block,Block}|Is]} end; -is_tagged_tuple([{block,[{set,_,_,_}=B|Bs]}, - {test,is_eq_exact,_,_}=I|Is],Fail,Src,Idx) -> - case is_tagged_tuple([{block,Bs},I|Is],Fail,Src,Idx) of - {Atom,[{block,Bsr}|Isr]} -> {Atom,[{block,[B|Bsr]}|Isr]}; - no -> no +is_tagged_tuple(_, _, _, _, _) -> + no. + +is_tagged_tuple_1([{set,[Dst],[Src],{get_tuple_element,0}}=I|Bl], + Is, Fail, Src, Dst, Idx, Def, Acc) -> + %% Check usage of Dst to find out whether the get_tuple_element + %% is needed. + case usage(Dst, Is, Fail, Idx) of + killed -> + %% Safe to remove the get_tuple_element instruction. + {yes,reverse(Acc, Bl)}; + used -> + %% Actively used. Must keep instruction. + {yes,reverse(Acc, [I|Bl])}; + not_used -> + %% Not actually used (but must be initialized). + case is_defined(Dst, Def) of + false -> + %% Dst must be initialized, but the + %% actual value does not matter. + Kill = {set,[Dst],[nil],move}, + {yes,reverse(Acc, [Kill|Bl])}; + true -> + %% The register is previously initialized. + %% We can remove the instruction. + {yes,reverse(Acc, Bl)} + end end; -is_tagged_tuple(_Is,_Fail,_Src,_Idx) -> +is_tagged_tuple_1([I|Bl], Is, Fail, Src, Dst, Idx, Def, Acc) -> + is_tagged_tuple_1(Bl, Is, Fail, Src, Dst, Idx, Def, [I|Acc]); +is_tagged_tuple_1(_, _, _, _, _, _, _, _) -> no. -is_killed(Dst,Is,{_,Lbl},Idx) -> - beam_utils:is_killed(Dst,Is,Idx) andalso - beam_utils:is_killed_at(Dst,Lbl,Idx). +usage(Dst, Is, Fail, Idx) -> + beam_utils:usage(Dst, [{test,is_number,Fail,[nil]}|Is], Idx). + +is_defined({x,X}, Def) -> + (Def bsr X) band 1 =:= 1. diff --git a/lib/compiler/src/beam_reorder.erl b/lib/compiler/src/beam_reorder.erl index 910b7f6b0a..63bb57a1ac 100644 --- a/lib/compiler/src/beam_reorder.erl +++ b/lib/compiler/src/beam_reorder.erl @@ -35,8 +35,7 @@ function({function,Name,Arity,CLabel,Is0}) -> Is = reorder(Is0), {function,Name,Arity,CLabel,Is} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. diff --git a/lib/compiler/src/beam_type.erl b/lib/compiler/src/beam_type.erl index 3d842a6fd3..b83ed17b55 100644 --- a/lib/compiler/src/beam_type.erl +++ b/lib/compiler/src/beam_type.erl @@ -40,11 +40,10 @@ function({function,Name,Arity,CLabel,Asm0}) -> Asm1 = beam_utils:live_opt(Asm0), Asm2 = opt(Asm1, [], tdb_new()), Asm3 = beam_utils:live_opt(Asm2), - Asm = beam_utils:delete_live_annos(Asm3), + Asm = beam_utils:delete_annos(Asm3), {function,Name,Arity,CLabel,Asm} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. @@ -81,96 +80,99 @@ simplify(Is0, TypeDb0) -> %% Basic simplification, mostly tuples, no floating point optimizations. simplify_basic(Is, Ts) -> - simplify_basic_1(Is, Ts, []). - -simplify_basic_1([{set,[D],[{integer,Index},Reg],{bif,element,_}}=I0|Is], Ts0, Acc) -> - I = case max_tuple_size(Reg, Ts0) of - Sz when 0 < Index, Index =< Sz -> - {set,[D],[Reg],{get_tuple_element,Index-1}}; - _Other -> I0 - end, - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]); -simplify_basic_1([{set,[D],[TupleReg],{get_tuple_element,0}}=I|Is0], Ts0, Acc) -> - case tdb_find(TupleReg, Ts0) of - {tuple,_,[Contents]} -> - simplify_basic_1([{set,[D],[Contents],move}|Is0], Ts0, Acc); - _ -> - Ts = update(I, Ts0), - simplify_basic_1(Is0, Ts, [I|Acc]) + simplify_basic(Is, Ts, []). + +simplify_basic([I0|Is], Ts0, Acc) -> + case simplify_instr(I0, Ts0) of + [] -> + simplify_basic(Is, Ts0, Acc); + [I] -> + Ts = update(I, Ts0), + simplify_basic(Is, Ts, [I|Acc]) + end; +simplify_basic([], Ts, Acc) -> + {reverse(Acc),Ts}. + +simplify_instr({set,[D],[{integer,Index},Reg],{bif,element,_}}=I, Ts) -> + case max_tuple_size(Reg, Ts) of + Sz when 0 < Index, Index =< Sz -> + [{set,[D],[Reg],{get_tuple_element,Index-1}}]; + _ -> [I] + end; +simplify_instr({test,is_atom,_,[R]}=I, Ts) -> + case tdb_find(R, Ts) of + boolean -> []; + _ -> [I] end; -simplify_basic_1([{set,_,_,{try_catch,_,_}}=I|Is], _Ts, Acc) -> - simplify_basic_1(Is, tdb_new(), [I|Acc]); -simplify_basic_1([{test,is_atom,_,[R]}=I|Is], Ts, Acc) -> +simplify_instr({test,is_integer,_,[R]}=I, Ts) -> + case tdb_find(R, Ts) of + integer -> []; + {integer,_} -> []; + _ -> [I] + end; +simplify_instr({set,[D],[TupleReg],{get_tuple_element,0}}=I, Ts) -> + case tdb_find(TupleReg, Ts) of + {tuple,_,_,[Contents]} -> + [{set,[D],[Contents],move}]; + _ -> + [I] + end; +simplify_instr({test,is_tuple,_,[R]}=I, Ts) -> case tdb_find(R, Ts) of - boolean -> simplify_basic_1(Is, Ts, Acc); - _ -> simplify_basic_1(Is, Ts, [I|Acc]) + {tuple,_,_,_} -> []; + _ -> [I] end; -simplify_basic_1([{test,is_integer,_,[R]}=I|Is], Ts, Acc) -> +simplify_instr({test,test_arity,_,[R,Arity]}=I, Ts) -> case tdb_find(R, Ts) of - integer -> simplify_basic_1(Is, Ts, Acc); - {integer,_} -> simplify_basic_1(Is, Ts, Acc); - _ -> simplify_basic_1(Is, Ts, [I|Acc]) + {tuple,exact_size,Arity,_} -> []; + _ -> [I] end; -simplify_basic_1([{test,is_tuple,_,[R]}=I|Is], Ts, Acc) -> +simplify_instr({test,is_map,_,[R]}=I, Ts) -> case tdb_find(R, Ts) of - {tuple,_,_} -> simplify_basic_1(Is, Ts, Acc); - _ -> simplify_basic_1(Is, Ts, [I|Acc]) + map -> []; + _ -> [I] end; -simplify_basic_1([{test,test_arity,_,[R,Arity]}=I|Is], Ts0, Acc) -> - case tdb_find(R, Ts0) of - {tuple,Arity,_} -> - simplify_basic_1(Is, Ts0, Acc); - _Other -> - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]) +simplify_instr({test,is_nonempty_list,_,[R]}=I, Ts) -> + case tdb_find(R, Ts) of + nonempty_list -> []; + _ -> [I] end; -simplify_basic_1([{test,is_map,_,[R]}=I|Is], Ts0, Acc) -> - case tdb_find(R, Ts0) of - map -> simplify_basic_1(Is, Ts0, Acc); - _Other -> - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]) +simplify_instr({test,is_eq_exact,Fail,[R,{atom,_}=Atom]}=I, Ts) -> + case tdb_find(R, Ts) of + {atom,_}=Atom -> []; + {atom,_} -> [{jump,Fail}]; + _ -> [I] end; -simplify_basic_1([{test,is_nonempty_list,_,[R]}=I|Is], Ts0, Acc) -> - case tdb_find(R, Ts0) of - nonempty_list -> simplify_basic_1(Is, Ts0, Acc); - _Other -> - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]) - end; -simplify_basic_1([{test,is_eq_exact,Fail,[R,{atom,_}=Atom]}=I|Is0], Ts0, Acc0) -> - Acc = case tdb_find(R, Ts0) of - {atom,_}=Atom -> Acc0; - {atom,_} -> [{jump,Fail}|Acc0]; - _ -> [I|Acc0] - end, - Ts = update(I, Ts0), - simplify_basic_1(Is0, Ts, Acc); -simplify_basic_1([{test,is_record,_,[R,{atom,_}=Tag,{integer,Arity}]}=I|Is], Ts0, Acc) -> - case tdb_find(R, Ts0) of - {tuple,Arity,[Tag]} -> - simplify_basic_1(Is, Ts0, Acc); - _Other -> - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]) - end; -simplify_basic_1([{select,select_val,Reg,_,_}=I0|Is], Ts, Acc) -> - I = case tdb_find(Reg, Ts) of - {integer,Range} -> - simplify_select_val_int(I0, Range); - boolean -> - simplify_select_val_bool(I0); - _ -> - I0 - end, - simplify_basic_1(Is, tdb_new(), [I|Acc]); -simplify_basic_1([I|Is], Ts0, Acc) -> - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]); -simplify_basic_1([], Ts, Acc) -> - Is = reverse(Acc), - {Is,Ts}. +simplify_instr({test,is_record,_,[R,{atom,_}=Tag,{integer,Arity}]}=I, Ts) -> + case tdb_find(R, Ts) of + {tuple,exact_size,Arity,[Tag]} -> []; + _ -> [I] + end; +simplify_instr({select,select_val,Reg,_,_}=I, Ts) -> + [case tdb_find(Reg, Ts) of + {integer,Range} -> + simplify_select_val_int(I, Range); + boolean -> + simplify_select_val_bool(I); + _ -> + I + end]; +simplify_instr({test,bs_test_unit,_,[Src,Unit]}=I, Ts) -> + case tdb_find(Src, Ts) of + {binary,U} when U rem Unit =:= 0 -> []; + _ -> [I] + end; +simplify_instr({test,is_binary,_,[Src]}=I, Ts) -> + case tdb_find(Src, Ts) of + {binary,U} when U rem 8 =:= 0 -> []; + _ -> [I] + end; +simplify_instr({test,is_bitstr,_,[Src]}=I, Ts) -> + case tdb_find(Src, Ts) of + {binary,_} -> []; + _ -> [I] + end; +simplify_instr(I, _) -> [I]. simplify_select_val_int({select,select_val,R,_,L0}=I, {Min,Max}) -> Vs = sort([V || {integer,V} <- L0]), @@ -301,7 +303,7 @@ clearerror([], OrigIs) -> [{set,[],[],fclearerror}|OrigIs]. %% Combine two blocks and eliminate any move instructions that assign %% to registers that are killed later in the block. %% -merge_blocks(B1, [{'%live',_,_}|B2]) -> +merge_blocks(B1, [{'%anno',_}|B2]) -> merge_blocks_1(B1++[{set,[],[],stop_here}|B2]). merge_blocks_1([{set,[],_,stop_here}|Is]) -> Is; @@ -350,27 +352,17 @@ flt_need_heap_2({set,_,_,{put_tuple,_}}, H, Fl) -> {[],H+1,Fl}; flt_need_heap_2({set,_,_,put}, H, Fl) -> {[],H+1,Fl}; -%% Then the "neutral" instructions. We just pass them. -flt_need_heap_2({set,[{fr,_}],_,_}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,[],[],fclearerror}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,[],[],fcheckerror}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,_,_,{bif,_,_}}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,_,_,move}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,_,_,{get_tuple_element,_}}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,_,_,get_list}, H, Fl) -> - {[],H,Fl}; -flt_need_heap_2({set,_,_,{try_catch,_,_}}, H, Fl) -> - {[],H,Fl}; -%% All other instructions should cause the insertion of an allocation +%% The following instructions cause the insertion of an allocation %% instruction if needed. +flt_need_heap_2({set,_,_,{alloc,_,_}}, H, Fl) -> + {flt_alloc(H, Fl),0,0}; +flt_need_heap_2({set,_,_,{set_tuple_element,_}}, H, Fl) -> + {flt_alloc(H, Fl),0,0}; +flt_need_heap_2({'%anno',_}, H, Fl) -> + {flt_alloc(H, Fl),0,0}; +%% All other instructions are "neutral". We just pass them. flt_need_heap_2(_, H, Fl) -> - {flt_alloc(H, Fl),0,0}. + {[],H,Fl}. flt_alloc(0, 0) -> []; @@ -393,7 +385,7 @@ build_alloc(Words, Floats) -> {alloc,[{words,Words},{floats,Floats}]}. %% is not continous at an allocation function (e.g. if {x,0} and {x,2} %% are live, but not {x,1}). -flt_liveness([{'%live',_Live,Regs}=LiveInstr|Is]) -> +flt_liveness([{'%anno',{used,Regs}}=LiveInstr|Is]) -> flt_liveness_1(Is, Regs, [LiveInstr]). flt_liveness_1([{set,Ds,Ss,{alloc,Live0,Alloc}}|Is], Regs0, Acc) -> @@ -405,7 +397,7 @@ flt_liveness_1([{set,Ds,Ss,{alloc,Live0,Alloc}}|Is], Regs0, Acc) -> flt_liveness_1([{set,Ds,_,_}=I|Is], Regs0, Acc) -> Regs = x_live(Ds, Regs0), flt_liveness_1(Is, Regs, [I|Acc]); -flt_liveness_1([{'%live',_,_}], _Regs, Acc) -> +flt_liveness_1([{'%anno',_}], _Regs, Acc) -> reverse(Acc). init_regs(Live) -> @@ -429,13 +421,14 @@ x_live([], Regs) -> Regs. %% Update the type database to account for executing an instruction. %% %% First the cases for instructions inside basic blocks. -update({'%live',_,_}, Ts) -> Ts; +update({'%anno',_}, Ts) -> + Ts; update({set,[D],[S],move}, Ts) -> tdb_copy(S, D, Ts); update({set,[D],[{integer,I},Reg],{bif,element,_}}, Ts0) -> - tdb_update([{Reg,{tuple,I,[]}},{D,kill}], Ts0); + tdb_update([{Reg,{tuple,min_size,I,[]}},{D,kill}], Ts0); update({set,[D],[_Index,Reg],{bif,element,_}}, Ts0) -> - tdb_update([{Reg,{tuple,0,[]}},{D,kill}], Ts0); + tdb_update([{Reg,{tuple,min_size,0,[]}},{D,kill}], Ts0); update({set,[D],Args,{bif,N,_}}, Ts0) -> Ar = length(Args), BoolOp = erl_internal:new_type_test(N, Ar) orelse @@ -484,8 +477,6 @@ update({set,[D],[S1,S2],{alloc,_,{gc_bif,Op,{f,0}}}}, Ts0) -> update({set,[],_Src,_Op}, Ts0) -> Ts0; update({set,[D],_Src,_Op}, Ts0) -> tdb_update([{D,kill}], Ts0); -update({set,[D1,D2],_Src,_Op}, Ts0) -> - tdb_update([{D1,kill},{D2,kill}], Ts0); update({kill,D}, Ts) -> tdb_update([{D,kill}], Ts); @@ -493,7 +484,7 @@ update({kill,D}, Ts) -> update({test,is_float,_Fail,[Src]}, Ts0) -> tdb_update([{Src,float}], Ts0); update({test,test_arity,_Fail,[Src,Arity]}, Ts0) -> - tdb_update([{Src,{tuple,Arity,[]}}], Ts0); + tdb_update([{Src,{tuple,exact_size,Arity,[]}}], Ts0); update({test,is_map,_Fail,[Src]}, Ts0) -> tdb_update([{Src,map}], Ts0); update({get_map_elements,_,Src,{list,Elems0}}, Ts0) -> @@ -507,15 +498,19 @@ update({test,is_eq_exact,_,[Reg,{atom,_}=Atom]}, Ts) -> error -> Ts; {tuple_element,TupleReg,0} -> - tdb_update([{TupleReg,{tuple,1,[Atom]}}], Ts); + tdb_update([{TupleReg,{tuple,min_size,1,[Atom]}}], Ts); _ -> Ts end; update({test,is_record,_Fail,[Src,Tag,{integer,Arity}]}, Ts) -> - tdb_update([{Src,{tuple,Arity,[Tag]}}], Ts); + tdb_update([{Src,{tuple,exact_size,Arity,[Tag]}}], Ts); -%% Binary matching +%% Binaries and binary matching. +update({test,is_binary,_Fail,[Src]}, Ts0) -> + tdb_update([{Src,{binary,8}}], Ts0); +update({test,is_bitstr,_Fail,[Src]}, Ts0) -> + tdb_update([{Src,{binary,1}}], Ts0); update({test,bs_get_integer2,_,_,Args,Dst}, Ts) -> tdb_update([{Dst,get_bs_integer_type(Args)}], Ts); update({test,bs_get_utf8,_,_,_,Dst}, Ts) -> @@ -524,8 +519,10 @@ update({test,bs_get_utf16,_,_,_,Dst}, Ts) -> tdb_update([{Dst,?UNICODE_INT}], Ts); update({test,bs_get_utf32,_,_,_,Dst}, Ts) -> tdb_update([{Dst,?UNICODE_INT}], Ts); +update({bs_init,_,{bs_init2,_,_},_,_,Dst}, Ts) -> + tdb_update([{Dst,{binary,8}}], Ts); update({bs_init,_,_,_,_,Dst}, Ts) -> - tdb_update([{Dst,kill}], Ts); + tdb_update([{Dst,{binary,1}}], Ts); update({bs_put,_,_,_}, Ts) -> Ts; update({bs_save2,_,_}, Ts) -> @@ -534,12 +531,19 @@ update({bs_restore2,_,_}, Ts) -> Ts; update({bs_context_to_binary,Dst}, Ts) -> tdb_update([{Dst,kill}], Ts); -update({test,bs_start_match2,_,_,_,Dst}, Ts) -> - tdb_update([{Dst,kill}], Ts); -update({test,bs_get_binary2,_,_,_,Dst}, Ts) -> - tdb_update([{Dst,kill}], Ts); +update({test,bs_start_match2,_,_,[Src,_],Dst}, Ts) -> + Type = case tdb_find(Src, Ts) of + {binary,_}=Type0 -> Type0; + _ -> {binary,1} + end, + tdb_update([{Dst,Type}], Ts); +update({test,bs_get_binary2,_,_,[_,_,Unit,_],Dst}, Ts) -> + true = is_integer(Unit), %Assertion. + tdb_update([{Dst,{binary,Unit}}], Ts); update({test,bs_get_float2,_,_,_,Dst}, Ts) -> tdb_update([{Dst,float}], Ts); +update({test,bs_test_unit,_,[Src,Unit]}, Ts) -> + tdb_update([{Src,{binary,Unit}}], Ts); update({test,_Test,_Fail,_Other}, Ts) -> Ts; @@ -554,7 +558,7 @@ update({call_ext,Ar,{extfunc,math,Math,Ar}}, Ts) -> update({call_ext,3,{extfunc,erlang,setelement,3}}, Ts0) -> Ts = tdb_kill_xregs(Ts0), case tdb_find({x,1}, Ts0) of - {tuple,Sz,_}=T0 -> + {tuple,SzKind,Sz,_}=T0 -> T = case tdb_find({x,0}, Ts0) of {integer,{I,I}} when I > 1 -> %% First element is not changed. The result @@ -563,7 +567,7 @@ update({call_ext,3,{extfunc,erlang,setelement,3}}, Ts0) -> _ -> %% Position is 1 or unknown. May change the %% first element of the tuple. - {tuple,Sz,[]} + {tuple,SzKind,Sz,[]} end, tdb_update([{{x,0},T}], Ts); _ -> @@ -576,6 +580,7 @@ update({call_fun, _}, Ts) -> tdb_kill_xregs(Ts); update({apply, _}, Ts) -> tdb_kill_xregs(Ts); update({line,_}, Ts) -> Ts; +update({'%',_}, Ts) -> Ts; %% The instruction is unknown. Kill all information. update(_I, _Ts) -> tdb_new(). @@ -647,7 +652,7 @@ possibly_numeric(_) -> false. max_tuple_size(Reg, Ts) -> case tdb_find(Reg, Ts) of - {tuple,Sz,_} -> Sz; + {tuple,_,Sz,_} -> Sz; _Other -> 0 end. @@ -803,16 +808,20 @@ checkerror_2(OrigIs) -> [{set,[],[],fcheckerror}|OrigIs]. %%% Routines for maintaining a type database. The type database %%% associates type information with registers. %%% -%%% {tuple,Size,First} means that the corresponding register contains a -%%% tuple with *at least* Size elements. An tuple with unknown -%%% size is represented as {tuple,0,[]}. First is either [] (meaning that -%%% the tuple's first element is unknown) or [FirstElement] (the contents -%%% of the first element). +%%% {tuple,min_size,Size,First} means that the corresponding register contains +%%% a tuple with *at least* Size elements (conversely, exact_size means that it +%%% contains a tuple with *exactly* Size elements). An tuple with unknown size +%%% is represented as {tuple,min_size,0,[]}. First is either [] (meaning that +%%% the tuple's first element is unknown) or [FirstElement] (the contents of +%%% the first element). %%% %%% 'float' means that the register contains a float. %%% %%% 'integer' or {integer,{Min,Max}} that the register contains an %%% integer. +%%% +%%% {binary,Unit} means that the register contains a binary/bitstring aligned +%%% to unit Unit. %% tdb_new() -> EmptyDataBase %% Creates a new, empty type database. @@ -851,7 +860,7 @@ tdb_copy(Literal, D, Ts) -> {literal,#{}} -> map; {literal,Tuple} when tuple_size(Tuple) >= 1 -> Lit = tag_literal(element(1, Tuple)), - {tuple,tuple_size(Tuple),[Lit]}; + {tuple,exact_size,tuple_size(Tuple),[Lit]}; _ -> term end, if @@ -873,14 +882,14 @@ tag_literal(Lit) -> {literal,Lit}. %% Updates a type database. If a 'kill' operation is given, the type %% information for that register will be removed from the database. %% A kill operation takes precedence over other operations for the same -%% register (i.e. [{{x,0},kill},{{x,0},{tuple,5,[]}}] means that the +%% register (i.e. [{{x,0},kill},{{x,0},{tuple,min_size,5,[]}}] means that the %% the existing type information, if any, will be discarded, and the -%% the '{tuple,5,[]}' information ignored. +%% the '{tuple,min_size,5,[]}' information ignored. %% %% If NewInfo information is given and there exists information about %% the register, the old and new type information will be merged. -%% For instance, {tuple,5,_} and {tuple,10,_} will be merged to produce -%% {tuple,10,_}. +%% For instance, {tuple,min_size,5,_} and {tuple,min_size,10,_} will be merged +%% to produce {tuple,min_size,10,_}. tdb_update(Uis0, Ts0) -> Uis1 = filter(fun ({{x,_},_Op}) -> true; @@ -918,34 +927,41 @@ tdb_kill_xregs([]) -> []. remove_key(Key, [{Key,_Op}|Ops]) -> remove_key(Key, Ops); remove_key(_, Ops) -> Ops. - + merge_type_info(I, I) -> I; -merge_type_info({tuple,Sz1,Same}, {tuple,Sz2,Same}=Max) when Sz1 < Sz2 -> +merge_type_info({tuple,min_size,Sz1,Same}, {tuple,min_size,Sz2,Same}=Max) when Sz1 < Sz2 -> Max; -merge_type_info({tuple,Sz1,Same}=Max, {tuple,Sz2,Same}) when Sz1 > Sz2 -> +merge_type_info({tuple,min_size,Sz1,Same}=Max, {tuple,min_size,Sz2,Same}) when Sz1 > Sz2 -> Max; -merge_type_info({tuple,Sz1,[]}, {tuple,_Sz2,First}=Tuple2) -> - merge_type_info({tuple,Sz1,First}, Tuple2); -merge_type_info({tuple,_Sz1,First}=Tuple1, {tuple,Sz2,_}) -> - merge_type_info(Tuple1, {tuple,Sz2,First}); -merge_type_info(integer, {integer,_}=Int) -> - Int; -merge_type_info({integer,_}=Int, integer) -> - Int; +merge_type_info({tuple,exact_size,_,Same}=Exact, {tuple,_,_,Same}) -> + Exact; +merge_type_info({tuple,_,_,Same},{tuple,exact_size,_,Same}=Exact) -> + Exact; +merge_type_info({tuple,SzKind1,Sz1,[]}, {tuple,_SzKind2,_Sz2,First}=Tuple2) -> + merge_type_info({tuple,SzKind1,Sz1,First}, Tuple2); +merge_type_info({tuple,_SzKind1,_Sz1,First}=Tuple1, {tuple,SzKind2,Sz2,_}) -> + merge_type_info(Tuple1, {tuple,SzKind2,Sz2,First}); +merge_type_info(integer, {integer,_}) -> + integer; +merge_type_info({integer,_}, integer) -> + integer; merge_type_info({integer,{Min1,Max1}}, {integer,{Min2,Max2}}) -> {integer,{max(Min1, Min2),min(Max1, Max2)}}; +merge_type_info({binary,U1}, {binary,U2}) -> + {binary,max(U1, U2)}; merge_type_info(NewType, _) -> verify_type(NewType), NewType. verify_type({atom,_}) -> ok; +verify_type({binary,U}) when is_integer(U) -> ok; verify_type(boolean) -> ok; verify_type(integer) -> ok; verify_type({integer,{Min,Max}}) when is_integer(Min), is_integer(Max) -> ok; verify_type(map) -> ok; verify_type(nonempty_list) -> ok; -verify_type({tuple,Sz,[]}) when is_integer(Sz) -> ok; -verify_type({tuple,Sz,[_]}) when is_integer(Sz) -> ok; +verify_type({tuple,_,Sz,[]}) when is_integer(Sz) -> ok; +verify_type({tuple,_,Sz,[_]}) when is_integer(Sz) -> ok; verify_type({tuple_element,_,_}) -> ok; verify_type(float) -> ok. diff --git a/lib/compiler/src/beam_utils.erl b/lib/compiler/src/beam_utils.erl index 00f396c246..4dcce30583 100644 --- a/lib/compiler/src/beam_utils.erl +++ b/lib/compiler/src/beam_utils.erl @@ -22,17 +22,20 @@ -module(beam_utils). -export([is_killed_block/2,is_killed/3,is_killed_at/3, - is_not_used/3, + is_not_used/3,usage/3, empty_label_index/0,index_label/3,index_labels/1,replace_labels/4, code_at/2,bif_to_test/3,is_pure_test/1, - live_opt/1,delete_live_annos/1,combine_heap_needs/2, - split_even/1]). + live_opt/1,delete_annos/1,combine_heap_needs/2, + anno_defs/1, + split_even/1 + ]). -export_type([code_index/0,module_code/0,instruction/0]). --import(lists, [map/2,member/2,sort/1,reverse/1,splitwith/2]). +-import(lists, [flatmap/2,map/2,member/2,sort/1,reverse/1,splitwith/2]). --define(is_const(Val), (element(1, Val) =:= integer orelse +-define(is_const(Val), (Val =:= nil orelse + element(1, Val) =:= integer orelse element(1, Val) =:= float orelse element(1, Val) =:= atom orelse element(1, Val) =:= literal)). @@ -59,6 +62,23 @@ {lbl :: code_index(), %Label to code index. res :: result_cache()}). %Result cache for each label. +%% usage(Register, [Instruction], State) -> killed|not_used|used. +%% Determine the usage of Register in the instruction sequence. +%% The return value is one of: +%% +%% killed - The register is not used in any way. +%% not_used - The register is referenced only by an allocating instruction +%% (the actual value does not matter). +%% used - The register is used (its value do matter). + +-spec usage(beam_asm:reg(), [instruction()], code_index()) -> + 'killed' | 'not_used' | 'used'. + +usage(R, Is, D) -> + St = #live{lbl=D,res=gb_trees:empty()}, + {Usage,_} = check_liveness(R, Is, St), + Usage. + %% is_killed_block(Register, [Instruction]) -> true|false %% Determine whether a register is killed by the instruction sequence inside @@ -75,7 +95,7 @@ is_killed_block({x,X}, [{set,_,_,{alloc,Live,_}}|_]) -> X >= Live; is_killed_block(R, [{set,Ds,Ss,_Op}|Is]) -> not member(R, Ss) andalso (member(R, Ds) orelse is_killed_block(R, Is)); -is_killed_block(R, [{'%live',_,Regs}|Is]) -> +is_killed_block(R, [{'%anno',{used,Regs}}|Is]) -> case R of {x,X} when (Regs bsr X) band 1 =:= 0 -> true; _ -> is_killed_block(R, Is) @@ -98,6 +118,7 @@ is_killed(R, Is, D) -> St = #live{lbl=D,res=gb_trees:empty()}, case check_liveness(R, Is, St) of {killed,_} -> true; + {exit_not_used,_} -> true; {_,_} -> false end. @@ -110,6 +131,7 @@ is_killed_at(R, Lbl, D) when is_integer(Lbl) -> St0 = #live{lbl=D,res=gb_trees:empty()}, case check_liveness_at(R, Lbl, St0) of {killed,_} -> true; + {exit_not_used,_} -> true; {_,_} -> false end. @@ -126,6 +148,7 @@ is_not_used(R, Is, D) -> St = #live{lbl=D,res=gb_trees:empty()}, case check_liveness(R, Is, St) of {used,_} -> false; + {exit_not_used,_} -> false; {_,_} -> true end. @@ -247,7 +270,7 @@ is_pure_test({test,Op,_,Ops}) -> %% Go through the instruction sequence in reverse execution %% order, keep track of liveness and remove 'move' instructions %% whose destination is a register that will not be used. -%% Also insert {'%live',Live,Regs} annotations at the beginning +%% Also insert {used,Regs} annotations at the beginning %% and end of each block. -spec live_opt([instruction()]) -> [instruction()]. @@ -262,35 +285,52 @@ live_opt(Is0) -> Bef ++ [Fi|live_opt(reverse(Is), 0, D, [])]. -%% delete_live_annos([Instruction]) -> [Instruction]. -%% Delete all live annotations. +%% delete_annos([Instruction]) -> [Instruction]. +%% Delete all annotations. --spec delete_live_annos([instruction()]) -> [instruction()]. +-spec delete_annos([instruction()]) -> [instruction()]. -delete_live_annos([{block,Bl0}|Is]) -> - case delete_live_annos(Bl0) of - [] -> delete_live_annos(Is); - [_|_]=Bl -> [{block,Bl}|delete_live_annos(Is)] +delete_annos([{block,Bl0}|Is]) -> + case delete_annos(Bl0) of + [] -> delete_annos(Is); + [_|_]=Bl -> [{block,Bl}|delete_annos(Is)] end; -delete_live_annos([{'%live',_,_}|Is]) -> - delete_live_annos(Is); -delete_live_annos([I|Is]) -> - [I|delete_live_annos(Is)]; -delete_live_annos([]) -> []. - +delete_annos([{'%anno',_}|Is]) -> + delete_annos(Is); +delete_annos([I|Is]) -> + [I|delete_annos(Is)]; +delete_annos([]) -> []. + %% combine_heap_needs(HeapNeed1, HeapNeed2) -> HeapNeed %% Combine the heap need for two allocation instructions. --spec combine_heap_needs(term(), term()) -> term(). +-type heap_need_tag() :: 'floats' | 'words'. +-type heap_need() :: non_neg_integer() | + {'alloc',[{heap_need_tag(),non_neg_integer()}]}. +-spec combine_heap_needs(heap_need(), heap_need()) -> heap_need(). -combine_heap_needs({alloc,Alloc1}, {alloc,Alloc2}) -> - {alloc,combine_alloc_lists(Alloc1, Alloc2)}; -combine_heap_needs({alloc,Alloc}, Words) when is_integer(Words) -> - {alloc,combine_alloc_lists(Alloc, [{words,Words}])}; -combine_heap_needs(Words, {alloc,Alloc}) when is_integer(Words) -> - {alloc,combine_alloc_lists(Alloc, [{words,Words}])}; combine_heap_needs(H1, H2) when is_integer(H1), is_integer(H2) -> - H1+H2. + H1 + H2; +combine_heap_needs(H1, H2) -> + {alloc,combine_alloc_lists([H1,H2])}. + + +%% anno_defs(Instructions) -> Instructions' +%% Add {def,RegisterBitmap} annotations to the beginning of +%% each block. Iff bit X is set in the the bitmap, it means +%% that {x,X} is defined when the block is entered. + +-spec anno_defs([instruction()]) -> [instruction()]. + +anno_defs(Is0) -> + {Bef,[Fi|Is1]} = + splitwith(fun({func_info,_,_,_}) -> false; + (_) -> true + end, Is0), + {func_info,_,_,Arity} = Fi, + Regs = init_def_regs(Arity), + Is = defs(Is1, Regs, #{}), + Bef ++ [Fi|Is]. %% split_even/1 %% [1,2,3,4,5,6] -> {[1,3,5],[2,4,6]} @@ -299,7 +339,6 @@ combine_heap_needs(H1, H2) when is_integer(H1), is_integer(H2) -> split_even(Rs) -> split_even(Rs, [], []). - %%% %%% Local functions. %%% @@ -311,12 +350,19 @@ split_even(Rs) -> split_even(Rs, [], []). %% %% killed - Reg is assigned or killed by an allocation instruction. %% not_used - the value of Reg is not used, but Reg must not be garbage +%% exit_not_used - the value of Reg is not used, but must not be garbage +%% because the stack will be scanned because an +%% exit BIF will raise an exception %% used - Reg is used check_liveness(R, [{block,Blk}|Is], St0) -> case check_liveness_block(R, Blk, St0) of {transparent,St1} -> check_liveness(R, Is, St1); + {alloc_used,St1} -> + %% Used by an allocating instruction, but value not referenced. + %% Must check the rest of the instructions. + not_used(check_liveness(R, Is, St1)); {Other,_}=Res when is_atom(Other) -> Res end; @@ -330,6 +376,8 @@ check_liveness(R, [{test,_,{f,Fail},As}|Is], St0) -> case check_liveness_at(R, Fail, St0) of {killed,St1} -> check_liveness(R, Is, St1); + {exit_not_used,St1} -> + check_liveness(R, Is, St1); {not_used,St1} -> not_used(check_liveness(R, Is, St1)); {used,_}=Used -> @@ -349,6 +397,8 @@ check_liveness(R, [{jump,{f,F}}|_], St) -> check_liveness_at(R, F, St); check_liveness(R, [{case_end,Used}|_], St) -> check_liveness_ret(R, Used, St); +check_liveness(R, [{try_case_end,Used}|_], St) -> + check_liveness_ret(R, Used, St); check_liveness(R, [{badmatch,Used}|_], St) -> check_liveness_ret(R, Used, St); check_liveness(_, [if_end|_], St) -> @@ -375,9 +425,16 @@ check_liveness(R, [{bs_init,_,_,none,Ss,Dst}|Is], St) -> check_liveness(R, [{bs_init,_,_,Live,Ss,Dst}|Is], St) -> case R of {x,X} -> - case X < Live orelse member(R, Ss) of - true -> {used,St}; - false -> {killed,St} + case member(R, Ss) of + true -> + {used,St}; + false -> + if + X < Live -> + not_used(check_liveness(R, Is, St)); + true -> + {killed,St} + end end; {y,_} -> case member(R, Ss) of @@ -385,7 +442,7 @@ check_liveness(R, [{bs_init,_,_,Live,Ss,Dst}|Is], St) -> false -> if R =:= Dst -> {killed,St}; - true -> check_liveness(R, Is, St) + true -> not_used(check_liveness(R, Is, St)) end end end; @@ -419,7 +476,7 @@ check_liveness(R, [{call_ext,Live,_}=I|Is], St) -> %% We must make sure we don't check beyond this %% instruction or we will fall through into random %% unrelated code and get stuck in a loop. - {killed,St} + {exit_not_used,St} end end; check_liveness(R, [{call_fun,Live}|Is], St) -> @@ -467,16 +524,12 @@ check_liveness(R, [{make_fun2,_,_,_,NumFree}|Is], St) -> {x,_} -> {killed,St}; {y,_} -> not_used(check_liveness(R, Is, St)) end; -check_liveness({x,_}=R, [{'catch',_,_}|Is], St) -> - %% All x registers will be killed if an exception occurs. - %% Therefore we only need to check the liveness for the - %% instructions following the catch instruction. - check_liveness(R, Is, St); -check_liveness({x,_}=R, [{'try',_,_}|Is], St) -> - %% All x registers will be killed if an exception occurs. - %% Therefore we only need to check the liveness for the - %% instructions inside the 'try' block. - check_liveness(R, Is, St); +check_liveness(R, [{'catch'=Op,Y,Fail}|Is], St) -> + Set = {set,[Y],[],{try_catch,Op,Fail}}, + check_liveness(R, [{block,[Set]}|Is], St); +check_liveness(R, [{'try'=Op,Y,Fail}|Is], St) -> + Set = {set,[Y],[],{try_catch,Op,Fail}}, + check_liveness(R, [{block,[Set]}|Is], St); check_liveness(R, [{try_end,Y}|Is], St) -> case R of Y -> @@ -537,15 +590,34 @@ check_liveness(R, [{get_map_elements,{f,Fail},S,{list,L}}|Is], St0) -> check_liveness(R, [{put_map,F,Op,S,D,Live,{list,Puts}}|Is], St) -> Set = {set,[D],[S|Puts],{alloc,Live,{put_map,Op,F}}}, check_liveness(R, [{block,[Set]}||Is], St); +check_liveness(R, [{put_tuple,Ar,D}|Is], St) -> + Set = {set,[D],[],{put_tuple,Ar}}, + check_liveness(R, [{block,[Set]}||Is], St); +check_liveness(R, [{put_list,S1,S2,D}|Is], St) -> + Set = {set,[D],[S1,S2],put_list}, + check_liveness(R, [{block,[Set]}||Is], St); check_liveness(R, [{test_heap,N,Live}|Is], St) -> I = {block,[{set,[],[],{alloc,Live,{nozero,nostack,N,[]}}}]}, check_liveness(R, [I|Is], St); check_liveness(R, [{allocate_zero,N,Live}|Is], St) -> I = {block,[{set,[],[],{alloc,Live,{zero,N,0,[]}}}]}, check_liveness(R, [I|Is], St); -check_liveness(R, [{get_list,S,D1,D2}|Is], St) -> - I = {block,[{set,[D1,D2],[S],get_list}]}, +check_liveness(R, [{get_hd,S,D}|Is], St) -> + I = {block,[{set,[D],[S],get_hd}]}, + check_liveness(R, [I|Is], St); +check_liveness(R, [{get_tl,S,D}|Is], St) -> + I = {block,[{set,[D],[S],get_tl}]}, check_liveness(R, [I|Is], St); +check_liveness(R, [remove_message|Is], St) -> + check_liveness(R, Is, St); +check_liveness({x,X}, [build_stacktrace|_], St) when X > 0 -> + {killed,St}; +check_liveness(R, [{recv_mark,_}|Is], St) -> + check_liveness(R, Is, St); +check_liveness(R, [{recv_set,_}|Is], St) -> + check_liveness(R, Is, St); +check_liveness(R, [{'%',_}|Is], St) -> + check_liveness(R, Is, St); check_liveness(_R, Is, St) when is_list(Is) -> %% Not implemented. Conservatively assume that the register is used. {used,St}. @@ -580,6 +652,7 @@ check_liveness_at(R, Lbl, #live{lbl=Ll,res=ResMemorized}=St0) -> {Res,St#live{res=gb_trees:insert(Lbl, Res, St#live.res)}} end. +not_used({exit_not_used,St}) -> {not_used,St}; not_used({killed,St}) -> {not_used,St}; not_used({_,_}=Res) -> Res. @@ -587,7 +660,7 @@ check_liveness_ret(R, R, St) -> {used,St}; check_liveness_ret(_, _, St) -> {killed,St}. %% check_liveness_block(Reg, [Instruction], State) -> -%% {killed | not_used | used | transparent,State'} +%% {killed | not_used | used | alloc_used | transparent,State'} %% Finds out how Reg is used in the instruction sequence inside a block. %% Returns one of: %% killed - Reg is assigned a new value or killed by an @@ -595,9 +668,10 @@ check_liveness_ret(_, _, St) -> {killed,St}. %% not_used - The value is not used, but the register is referenced %% e.g. by an allocation instruction %% transparent - Reg is neither used nor killed +%% alloc_used - Used only in an allocate instruction %% used - Reg is explicitly used by an instruction %% -%% '%live' annotations are not allowed. +%% Annotations are not allowed. %% %% (Unknown instructions will cause an exception.) @@ -607,13 +681,30 @@ check_liveness_block({x,X}=R, [{set,Ds,Ss,{alloc,Live,Op}}|Is], St0) -> {killed,St0}; true -> case check_liveness_block_1(R, Ss, Ds, Op, Is, St0) of - {killed,St} -> {not_used,St}; - {transparent,St} -> {not_used,St}; - {_,_}=Res -> Res + {transparent,St} -> {alloc_used,St}; + {_,_}=Res -> not_used(Res) end end; -check_liveness_block({y,_}=R, [{set,Ds,Ss,{alloc,_Live,Op}}|Is], St) -> - check_liveness_block_1(R, Ss, Ds, Op, Is, St); +check_liveness_block({y,_}=R, [{set,Ds,Ss,{alloc,_Live,Op}}|Is], St0) -> + case check_liveness_block_1(R, Ss, Ds, Op, Is, St0) of + {transparent,St} -> {alloc_used,St}; + {_,_}=Res -> not_used(Res) + end; +check_liveness_block({y,_}=R, [{set,Ds,Ss,{try_catch,_,Op}}|Is], St0) -> + case Ds of + [R] -> + {killed,St0}; + _ -> + case check_liveness_block_1(R, Ss, Ds, Op, Is, St0) of + {exit_not_used,St} -> + {used,St}; + {transparent,St} -> + %% Conservatively assumed that it is used. + {used,St}; + {_,_}=Res -> + Res + end + end; check_liveness_block(R, [{set,Ds,Ss,Op}|Is], St) -> check_liveness_block_1(R, Ss, Ds, Op, Is, St); check_liveness_block(_, [], St) -> {transparent,St}. @@ -629,6 +720,11 @@ check_liveness_block_1(R, Ss, Ds, Op, Is, St0) -> true -> {killed,St}; false -> check_liveness_block(R, Is, St) end; + {exit_not_used,St} -> + case member(R, Ds) of + true -> {exit_not_used,St}; + false -> check_liveness_block(R, Is, St) + end; {not_used,St} -> not_used(case member(R, Ds) of true -> {killed,St}; @@ -722,22 +818,18 @@ label(Old, D, Fb) -> _ -> Fb(Old) end. -%% Help functions for combine_heap_needs. - -combine_alloc_lists(Al1, Al2) -> - combine_alloc_lists_1(sort(Al1++Al2)). +%% Help function for combine_heap_needs. -combine_alloc_lists_1([{words,W1},{words,W2}|T]) - when is_integer(W1), is_integer(W2) -> - [{words,W1+W2}|combine_alloc_lists_1(T)]; -combine_alloc_lists_1([{floats,F1},{floats,F2}|T]) - when is_integer(F1), is_integer(F2) -> - [{floats,F1+F2}|combine_alloc_lists_1(T)]; -combine_alloc_lists_1([{words,_}=W|T]) -> - [W|combine_alloc_lists_1(T)]; -combine_alloc_lists_1([{floats,_}=F|T]) -> - [F|combine_alloc_lists_1(T)]; -combine_alloc_lists_1([]) -> []. +combine_alloc_lists(Al0) -> + Al1 = flatmap(fun(Words) when is_integer(Words) -> + [{words,Words}]; + ({alloc,List}) -> + List + end, Al0), + Al2 = sofs:relation(Al1), + Al3 = sofs:relation_to_family(Al2), + Al4 = sofs:to_external(Al3), + [{Tag,lists:sum(L)} || {Tag,L} <- Al4]. %% live_opt/4. @@ -776,10 +868,14 @@ live_opt([{test,bs_start_match2,Fail,Live,[Src,_],_}=I|Is], _, D, Acc) -> %% Other instructions. live_opt([{block,Bl0}|Is], Regs0, D, Acc) -> - Live0 = {'%live',live_regs(Regs0),Regs0}, + Live0 = make_anno({used,Regs0}), {Bl,Regs} = live_opt_block(reverse(Bl0), Regs0, D, [Live0]), - Live = {'%live',live_regs(Regs),Regs}, + Live = make_anno({used,Regs}), live_opt(Is, Regs, D, [{block,[Live|Bl]}|Acc]); +live_opt([build_stacktrace=I|Is], _, D, Acc) -> + live_opt(Is, live_call(1), D, [I|Acc]); +live_opt([raw_raise=I|Is], _, D, Acc) -> + live_opt(Is, live_call(3), D, [I|Acc]); live_opt([{label,L}=I|Is], Regs, D0, Acc) -> D = gb_trees:insert(L, Regs, D0), live_opt(Is, Regs, D, [I|Acc]); @@ -821,7 +917,8 @@ live_opt([{test,_,Fail,Live,Ss,_}=I|Is], _, D, Acc) -> Regs1 = x_live(Ss, Regs0), Regs = live_join_label(Fail, D, Regs1), live_opt(Is, Regs, D, [I|Acc]); -live_opt([{select,_,Src,Fail,List}=I|Is], Regs0, D, Acc) -> +live_opt([{select,_,Src,Fail,List}=I|Is], _, D, Acc) -> + Regs0 = 0, Regs1 = x_live([Src], Regs0), Regs = live_join_labels([Fail|List], D, Regs1), live_opt(Is, Regs, D, [I|Acc]); @@ -844,6 +941,25 @@ live_opt([{get_map_elements,Fail,Src,{list,List}}=I|Is], Regs0, D, Acc) -> Regs1 = x_live([Src|Ss], x_dead(Ds, Regs0)), Regs = live_join_label(Fail, D, Regs1), live_opt(Is, Regs, D, [I|Acc]); +live_opt([{gc_bif,N,F,R,As,Dst}=I|Is], Regs0, D, Acc) -> + Bl = [{set,[Dst],As,{alloc,R,{gc_bif,N,F}}}], + {_,Regs} = live_opt_block(Bl, Regs0, D, []), + live_opt(Is, Regs, D, [I|Acc]); +live_opt([{bif,N,F,As,Dst}=I|Is], Regs0, D, Acc) -> + Bl = [{set,[Dst],As,{bif,N,F}}], + {_,Regs} = live_opt_block(Bl, Regs0, D, []), + live_opt(Is, Regs, D, [I|Acc]); +live_opt([{get_tuple_element,Src,Idx,Dst}=I|Is], Regs0, D, Acc) -> + Bl = [{set,[Dst],[Src],{get_tuple_element,Idx}}], + {_,Regs} = live_opt_block(Bl, Regs0, D, []), + live_opt(Is, Regs, D, [I|Acc]); +live_opt([{move,Src,Dst}=I|Is], Regs0, D, Acc) -> + Regs = x_live([Src], x_dead([Dst], Regs0)), + live_opt(Is, Regs, D, [I|Acc]); +live_opt([{put_map,F,Op,S,Dst,R,{list,Puts}}=I|Is], Regs0, D, Acc) -> + Bl = [{set,[Dst],[S|Puts],{alloc,R,{put_map,Op,F}}}], + {_,Regs} = live_opt_block(Bl, Regs0, D, []), + live_opt(Is, Regs, D, [I|Acc]); %% Transparent instructions - they neither use nor modify x registers. live_opt([{deallocate,_}=I|Is], Regs, D, Acc) -> @@ -860,6 +976,10 @@ live_opt([{wait_timeout,_,{Tag,_}}=I|Is], Regs, D, Acc) when Tag =/= x -> live_opt(Is, Regs, D, [I|Acc]); live_opt([{line,_}=I|Is], Regs, D, Acc) -> live_opt(Is, Regs, D, [I|Acc]); +live_opt([{'catch',_,_}=I|Is], Regs, D, Acc) -> + live_opt(Is, Regs, D, [I|Acc]); +live_opt([{'try',_,_}=I|Is], Regs, D, Acc) -> + live_opt(Is, Regs, D, [I|Acc]); %% The following instructions can occur if the "compilation" has been %% started from a .S file using the 'from_asm' option. @@ -890,7 +1010,7 @@ live_opt_block([{set,Ds,Ss,Op0}|Is], Regs0, D, Acc) -> _ -> live_opt_block(Is, Regs, D, [I|Acc]) end; -live_opt_block([{'%live',_,_}|Is], Regs, D, Acc) -> +live_opt_block([{'%anno',_}|Is], Regs, D, Acc) -> live_opt_block(Is, Regs, D, Acc); live_opt_block([], Regs, _, Acc) -> {Acc,Regs}. @@ -950,3 +1070,220 @@ split_even([], Ss, Ds) -> {reverse(Ss),reverse(Ds)}; split_even([S,D|Rs], Ss, Ds) -> split_even(Rs, [S|Ss], [D|Ds]). + +%%% +%%% Add annotations for defined registers. +%%% +%%% This analysis is done by scanning the instructions in +%%% execution order. +%%% + +defs([{apply,_}=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; +defs([{bif,_,{f,Fail},_Src,Dst}=I|Is], Regs0, D) -> + Regs = def_regs([Dst], Regs0), + [I|defs(Is, Regs, update_regs(Fail, Regs0, D))]; +defs([{block,Block0}|Is], Regs0, D0) -> + {Block,Regs,D} = defs_list(Block0, Regs0, D0), + [{block,[make_anno({def,Regs0})|Block]}|defs(Is, Regs, D)]; +defs([{bs_init,{f,L},_,_,_,Dst}=I|Is], Regs0, D) -> + Regs = def_regs([Dst], Regs0), + [I|defs(Is, Regs, update_regs(L, Regs, D))]; +defs([{bs_put,{f,L},_,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, update_regs(L, Regs, D))]; +defs([build_stacktrace=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; +defs([{call,_,_}=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; +defs([{call_ext,_,{extfunc,M,F,A}}=I|Is], _Regs, D) -> + case erl_bifs:is_exit_bif(M, F, A) of + false -> + [I|defs(Is, 1, D)]; + true -> + [I|defs_unreachable(Is, D)] + end; +defs([{call_ext,_,_}=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; +defs([{call_fun,_}=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; +defs([{'catch',_,{f,L}}=I|Is], Regs, D) -> + RegsAtLabel = init_def_regs(1), + [I|defs(Is, Regs, update_regs(L, RegsAtLabel, D))]; +defs([{catch_end,_}=I|Is], _Regs, D) -> + Regs = init_def_regs(1), + [I|defs(Is, Regs, D)]; +defs([{gc_bif,_,{f,Fail},Live,_Src,Dst}=I|Is], Regs0, D) -> + true = all_defined(Live, Regs0), %Assertion. + Regs = def_regs([Dst], init_def_regs(Live)), + [I|defs(Is, Regs, update_regs(Fail, Regs0, D))]; +defs([{get_map_elements,{f,L},_Src,{list,DstList}}=I|Is], Regs0, D) -> + {_,Ds} = beam_utils:split_even(DstList), + Regs = def_regs(Ds, Regs0), + [I|defs(Is, Regs, update_regs(L, Regs0, D))]; +defs([{get_tuple_element,_,_,Dst}=I|Is], Regs0, D) -> + Regs = def_regs([Dst], Regs0), + [I|defs(Is, Regs, D)]; +defs([{jump,{f,L}}=I|Is], Regs, D) -> + [I|defs_unreachable(Is, update_regs(L, Regs, D))]; +defs([{label,L}=I|Is], Regs0, D) -> + case D of + #{L:=Regs1} -> + Regs = Regs0 band Regs1, + [I|defs(Is, Regs, D)]; + #{} -> + [I|defs(Is, Regs0, D)] + end; +defs([{loop_rec,{f,L},{x,0}}=I|Is], _Regs, D0) -> + RegsAtLabel = init_def_regs(0), + D = update_regs(L, RegsAtLabel, D0), + [I|defs(Is, init_def_regs(1), D)]; +defs([{loop_rec_end,_}=I|Is], _Regs, D) -> + [I|defs(Is, 0, D)]; +defs([{make_fun2,_,_,_,_}=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; +defs([{move,_,Dst}=I|Is], Regs0, D) -> + Regs = def_regs([Dst], Regs0), + [I|defs(Is, Regs, D)]; +defs([{put_map,{f,Fail},_,_,Dst,_,_}=I|Is], Regs0, D) -> + Regs = def_regs([Dst], Regs0), + [I|defs(Is, Regs, update_regs(Fail, Regs0, D))]; +defs([raw_raise=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; +defs([return=I|Is], _Regs, D) -> + [I|defs_unreachable(Is, D)]; +defs([{select,_,_Src,Fail,List}=I|Is], Regs, D0) -> + D = update_list([Fail|List], Regs, D0), + [I|defs_unreachable(Is, D)]; +defs([{test,_,{f,L},_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, update_regs(L, Regs, D))]; +defs([{test,_,{f,L},Live,_,Dst}=I|Is], Regs0, D) -> + true = all_defined(Live, Regs0), %Assertion. + Regs = def_regs([Dst], init_def_regs(Live)), + [I|defs(Is, Regs, update_regs(L, Regs0, D))]; +defs([{'try',_,{f,L}}=I|Is], Regs, D) -> + RegsAtLabel = init_def_regs(3), + [I|defs(Is, Regs, update_regs(L, RegsAtLabel, D))]; +defs([{try_case,_}=I|Is], _Regs, D) -> + [I|defs(Is, init_def_regs(3), D)]; +defs([{wait,_}=I|Is], _Regs, D) -> + [I|defs_unreachable(Is, D)]; +defs([{wait_timeout,_,_}=I|Is], _Regs, D) -> + [I|defs(Is, 0, D)]; + +%% Exceptions. +defs([{badmatch,_}=I|Is], _Regs, D) -> + [I|defs_unreachable(Is, D)]; +defs([{case_end,_}=I|Is], _Regs, D) -> + [I|defs_unreachable(Is, D)]; +defs([if_end=I|Is], _Regs, D) -> + [I|defs_unreachable(Is, D)]; +defs([{try_case_end,_}=I|Is], _Regs, D) -> + [I|defs_unreachable(Is, D)]; + +%% Neutral instructions +defs([{bs_context_to_binary,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{bs_restore2,_,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{bs_save2,_,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{deallocate,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{kill,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{line,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{recv_mark,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{recv_set,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([timeout=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{trim,_,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{try_end,_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([{'%',_}=I|Is], Regs, D) -> + [I|defs(Is, Regs, D)]; +defs([], _, _) -> []. + +defs_unreachable([{label,L}=I|Is], D) -> + case D of + #{L:=Regs} -> + [I|defs(Is, Regs, D)]; + #{} -> + defs_unreachable(Is, D) + end; +defs_unreachable([_|Is], D) -> + defs_unreachable(Is, D); +defs_unreachable([], _D) -> []. + +defs_list(Is, Regs, D) -> + defs_list(Is, Regs, D, []). + +defs_list([{set,Ds,_,{alloc,Live,Info}}=I|Is], Regs0, D0, Acc) -> + true = all_defined(Live, Regs0), %Assertion. + D = case Info of + {gc_bif,_,{f,Fail}} -> + update_regs(Fail, Regs0, D0); + {put_map,_,{f,Fail}} -> + update_regs(Fail, Regs0, D0); + _ -> + D0 + end, + Regs = def_regs(Ds, init_def_regs(Live)), + defs_list(Is, Regs, D, [I|Acc]); +defs_list([{set,Ds,_,Info}=I|Is], Regs0, D0, Acc) -> + D = case Info of + {bif,_,{f,Fail}} -> + update_regs(Fail, Regs0, D0); + {try_catch,'catch',{f,Fail}} -> + update_regs(Fail, init_def_regs(1), D0); + {try_catch,'try',{f,Fail}} -> + update_regs(Fail, init_def_regs(3), D0); + _ -> + D0 + end, + Regs = def_regs(Ds, Regs0), + defs_list(Is, Regs, D, [I|Acc]); +defs_list([], Regs, D, Acc) -> + {reverse(Acc),Regs,D}. + +init_def_regs(Arity) -> + (1 bsl Arity) - 1. + +def_regs([{x,X}|T], Regs) -> + def_regs(T, Regs bor (1 bsl X)); +def_regs([_|T], Regs) -> + def_regs(T, Regs); +def_regs([], Regs) -> Regs. + +update_list([{f,L}|T], Regs, D0) -> + D = update_regs(L, Regs, D0), + update_list(T, Regs, D); +update_list([_|T], Regs, D) -> + update_list(T, Regs, D); +update_list([], _Regs, D) -> D. + +update_regs(L, Regs0, D) -> + case D of + #{L:=Regs1} -> + Regs = Regs0 band Regs1, + D#{L:=Regs}; + #{} -> + D#{L=>Regs0} + end. + +all_defined(Live, Regs) -> + All = (1 bsl Live) - 1, + Regs band All =:= All. + +%%% +%%% Utilities. +%%% + +%% make_anno(Anno) -> WrappedAnno. +%% Wrap an annotation term. + +make_anno(Anno) -> + {'%anno',Anno}. diff --git a/lib/compiler/src/beam_validator.erl b/lib/compiler/src/beam_validator.erl index be8908dd6b..7e5d86c177 100644 --- a/lib/compiler/src/beam_validator.erl +++ b/lib/compiler/src/beam_validator.erl @@ -85,8 +85,6 @@ format_error(Error) -> %%% Things currently not checked. XXX %%% %%% - Heap allocation for binaries. -%%% - That put_tuple is followed by the correct number of -%%% put instructions. %%% %% validate(Module, [Function]) -> [] | [Error] @@ -130,9 +128,8 @@ validate_0(Module, [{function,Name,Ar,Entry,Code}|Fs], Ft) -> throw:Error -> %% Controlled error. [Error|validate_0(Module, Fs, Ft)]; - Class:Error -> + Class:Error:Stack -> %% Crash. - Stack = erlang:get_stacktrace(), io:fwrite("Function: ~w/~w\n", [Name,Ar]), erlang:raise(Class, Error, Stack) end. @@ -149,7 +146,8 @@ validate_0(Module, [{function,Name,Ar,Entry,Code}|Fs], Ft) -> hf=0, %Available heap size for floats. fls=undefined, %Floating point state. ct=[], %List of hot catch/try labels - setelem=false %Previous instruction was setelement/3. + setelem=false, %Previous instruction was setelement/3. + puts_left=none %put/1 instructions left. }). -type label() :: integer(). @@ -294,6 +292,8 @@ valfun_1({bs_context_to_binary,Ctx}, #vst{current=#st{x=Xs}}=Vst) -> end; valfun_1(bs_init_writable=I, Vst) -> call(I, 1, Vst); +valfun_1(build_stacktrace=I, Vst) -> + call(I, 1, Vst); valfun_1({move,{y,_}=Src,{y,_}=Dst}, Vst) -> %% The stack trimming optimization may generate a move from an initialized %% but unassigned Y register to another Y register. @@ -339,11 +339,25 @@ valfun_1({put_list,A,B,Dst}, Vst0) -> Vst = eat_heap(2, Vst0), set_type_reg(cons, Dst, Vst); valfun_1({put_tuple,Sz,Dst}, Vst0) when is_integer(Sz) -> + Vst1 = eat_heap(1, Vst0), + Vst = set_type_reg(tuple_in_progress, Dst, Vst1), + #vst{current=St0} = Vst, + St = St0#st{puts_left={Sz,{Dst,{tuple,Sz}}}}, + Vst#vst{current=St}; +valfun_1({put,Src}, Vst0) -> + assert_term(Src, Vst0), Vst = eat_heap(1, Vst0), - set_type_reg({tuple,Sz}, Dst, Vst); -valfun_1({put,Src}, Vst) -> - assert_term(Src, Vst), - eat_heap(1, Vst); + #vst{current=St0} = Vst, + case St0 of + #st{puts_left=none} -> + error(not_building_a_tuple); + #st{puts_left={1,{Dst,Type}}} -> + St = St0#st{puts_left=none}, + set_type_reg(Type, Dst, Vst#vst{current=St}); + #st{puts_left={PutsLeft,Info}} when is_integer(PutsLeft) -> + St = St0#st{puts_left={PutsLeft-1,Info}}, + Vst#vst{current=St} + end; %% Instructions for optimization of selective receives. valfun_1({recv_mark,{f,Fail}}, Vst) when is_integer(Fail) -> Vst; @@ -523,15 +537,18 @@ valfun_4({bif,element,{f,Fail},[Pos,Tuple],Dst}, Vst0) -> valfun_4({bif,raise,{f,0},Src,_Dst}, Vst) -> validate_src(Src, Vst), kill_state(Vst); +valfun_4(raw_raise=I, Vst) -> + call(I, 3, Vst); valfun_4({bif,Op,{f,Fail},Src,Dst}, Vst0) -> validate_src(Src, Vst0), Vst = branch_state(Fail, Vst0), Type = bif_type(Op, Src, Vst), set_type_reg(Type, Dst, Vst); valfun_4({gc_bif,Op,{f,Fail},Live,Src,Dst}, #vst{current=St0}=Vst0) -> + verify_live(Live, Vst0), + verify_y_init(Vst0), St = kill_heap_allocation(St0), Vst1 = Vst0#vst{current=St}, - verify_live(Live, Vst1), Vst2 = branch_state(Fail, Vst1), Vst = prune_x_regs(Live, Vst2), validate_src(Src, Vst), @@ -574,6 +591,12 @@ valfun_4({get_list,Src,D1,D2}, Vst0) -> assert_type(cons, Src, Vst0), Vst = set_type_reg(term, D1, Vst0), set_type_reg(term, D2, Vst); +valfun_4({get_hd,Src,Dst}, Vst) -> + assert_type(cons, Src, Vst), + set_type_reg(term, Dst, Vst); +valfun_4({get_tl,Src,Dst}, Vst) -> + assert_type(cons, Src, Vst), + set_type_reg(term, Dst, Vst); valfun_4({get_tuple_element,Src,I,Dst}, Vst) -> assert_type({tuple_element,I+1}, Src, Vst), set_type_reg(term, Dst, Vst); @@ -685,6 +708,7 @@ valfun_4({bs_utf16_size,{f,Fail},A,Dst}, Vst) -> set_type_reg({integer,[]}, Dst, branch_state(Fail, Vst)); valfun_4({bs_init2,{f,Fail},Sz,Heap,Live,_,Dst}, Vst0) -> verify_live(Live, Vst0), + verify_y_init(Vst0), if is_integer(Sz) -> ok; @@ -697,6 +721,7 @@ valfun_4({bs_init2,{f,Fail},Sz,Heap,Live,_,Dst}, Vst0) -> set_type_reg(binary, Dst, Vst); valfun_4({bs_init_bits,{f,Fail},Sz,Heap,Live,_,Dst}, Vst0) -> verify_live(Live, Vst0), + verify_y_init(Vst0), if is_integer(Sz) -> ok; @@ -709,6 +734,7 @@ valfun_4({bs_init_bits,{f,Fail},Sz,Heap,Live,_,Dst}, Vst0) -> set_type_reg(binary, Dst, Vst); valfun_4({bs_append,{f,Fail},Bits,Heap,Live,_Unit,Bin,_Flags,Dst}, Vst0) -> verify_live(Live, Vst0), + verify_y_init(Vst0), assert_term(Bits, Vst0), assert_term(Bin, Vst0), Vst1 = heap_alloc(Heap, Vst0), @@ -944,6 +970,7 @@ deallocate(#vst{current=St}=Vst) -> test_heap(Heap, Live, Vst0) -> verify_live(Live, Vst0), + verify_y_init(Vst0), Vst = prune_x_regs(Live, Vst0), heap_alloc(Heap, Vst). @@ -1266,6 +1293,7 @@ get_move_term_type(Src, Vst) -> initialized -> error({unassigned,Src}); {catchtag,_} -> error({catchtag,Src}); {trytag,_} -> error({trytag,Src}); + tuple_in_progress -> error({tuple_in_progress,Src}); Type -> Type end. @@ -1274,10 +1302,7 @@ get_move_term_type(Src, Vst) -> %% a standard Erlang type (no catch/try tags or match contexts). get_term_type(Src, Vst) -> - case get_term_type_1(Src, Vst) of - initialized -> error({unassigned,Src}); - {catchtag,_} -> error({catchtag,Src}); - {trytag,_} -> error({trytag,Src}); + case get_move_term_type(Src, Vst) of #ms{} -> error({match_context,Src}); Type -> Type end. diff --git a/lib/compiler/src/beam_z.erl b/lib/compiler/src/beam_z.erl index 787e33c142..6c3a6995d7 100644 --- a/lib/compiler/src/beam_z.erl +++ b/lib/compiler/src/beam_z.erl @@ -24,22 +24,23 @@ -export([module/2]). --import(lists, [dropwhile/2]). +-import(lists, [dropwhile/2,map/2]). -spec module(beam_utils:module_code(), [compile:option()]) -> {'ok',beam_asm:module_code()}. -module({Mod,Exp,Attr,Fs0,Lc}, _Opt) -> - Fs = [function(F) || F <- Fs0], +module({Mod,Exp,Attr,Fs0,Lc}, Opts) -> + NoGetHdTl = proplists:get_bool(no_get_hd_tl, Opts), + Fs = [function(F, NoGetHdTl) || F <- Fs0], {ok,{Mod,Exp,Attr,Fs,Lc}}. -function({function,Name,Arity,CLabel,Is0}) -> +function({function,Name,Arity,CLabel,Is0}, NoGetHdTl) -> try - Is = undo_renames(Is0), + Is1 = undo_renames(Is0), + Is = maybe_eliminate_get_hd_tl(Is1, NoGetHdTl), {function,Name,Arity,CLabel,Is} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [Name,Arity]), erlang:raise(Class, Error, Stack) end. @@ -66,6 +67,10 @@ undo_renames([{bif,raise,_,_,_}=I|Is0]) -> (_) -> true end, Is0), [I|undo_renames(Is)]; +undo_renames([{get_hd,Src,Dst1},{get_tl,Src,Dst2}|Is]) -> + [{get_list,Src,Dst1,Dst2}|undo_renames(Is)]; +undo_renames([{get_tl,Src,Dst2},{get_hd,Src,Dst1}|Is]) -> + [{get_list,Src,Dst1,Dst2}|undo_renames(Is)]; undo_renames([I|Is]) -> [undo_rename(I)|undo_renames(Is)]; undo_renames([]) -> []. @@ -108,3 +113,17 @@ undo_rename({get_map_elements,Fail,Src,{list,List}}) -> undo_rename({select,I,Reg,Fail,List}) -> {I,Reg,Fail,{list,List}}; undo_rename(I) -> I. + +%%% +%%% Eliminate get_hd/get_tl instructions if requested by +%%% the no_get_hd_tl option. +%%% + +maybe_eliminate_get_hd_tl(Is, true) -> + map(fun({get_hd,Cons,Hd}) -> + {get_list,Cons,Hd,{x,1022}}; + ({get_tl,Cons,Tl}) -> + {get_list,Cons,{x,1022},Tl}; + (I) -> I + end, Is); +maybe_eliminate_get_hd_tl(Is, false) -> Is. diff --git a/lib/compiler/src/cerl_clauses.erl b/lib/compiler/src/cerl_clauses.erl index 7d6518c3c6..fa5104c01b 100644 --- a/lib/compiler/src/cerl_clauses.erl +++ b/lib/compiler/src/cerl_clauses.erl @@ -353,6 +353,8 @@ match(P, E, Bs) -> map -> %% The most we can do is to say "definitely no match" if a %% map pattern is matched against non-map data. + %% (Note: See the document internal_doc/cerl-notes.md for + %% information why we don't try to do more here.) case E of any -> {false, Bs}; diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl index 1b359d1e59..c6a0056a70 100644 --- a/lib/compiler/src/compile.erl +++ b/lib/compiler/src/compile.erl @@ -203,7 +203,12 @@ expand_opts(Opts0) -> {_,_,undefined} -> [debug_info|Opts0]; {_,_,_} -> Opts0 end, - foldr(fun expand_opt/2, [], Opts). + %% iff,unless processing is to complex... + Opts1 = case proplists:is_defined(makedep_side_effect,Opts) of + true -> proplists:delete(makedep,Opts); + false -> Opts + end, + foldr(fun expand_opt/2, [], Opts1). expand_opt(basic_validation, Os) -> [no_code_generation,to_pp,binary|Os]; @@ -214,13 +219,15 @@ expand_opt(report, Os) -> expand_opt(return, Os) -> [return_errors,return_warnings|Os]; expand_opt(r16, Os) -> - [no_record_opt,no_utf8_atoms|Os]; + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; expand_opt(r17, Os) -> - [no_record_opt,no_utf8_atoms|Os]; + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; expand_opt(r18, Os) -> - [no_record_opt,no_utf8_atoms|Os]; + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; expand_opt(r19, Os) -> - [no_record_opt,no_utf8_atoms|Os]; + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; +expand_opt(r20, Os) -> + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; expand_opt({debug_info_key,_}=O, Os) -> [encrypt_debug_info,O|Os]; expand_opt(no_float_opt, Os) -> @@ -674,6 +681,7 @@ select_list_passes_1([], _, Acc) -> standard_passes() -> [?pass(transform_module), + {iff,makedep_side_effect,?pass(makedep_and_output)}, {iff,makedep,[ ?pass(makedep), {unless,binary,?pass(makedep_output)} @@ -733,8 +741,6 @@ kernel_passes() -> ?pass(v3_kernel), {iff,dkern,{listing,"kernel"}}, {iff,'to_kernel',{done,"kernel"}}, - {pass,v3_life}, - {iff,dlife,{listing,"life"}}, {pass,v3_codegen}, {iff,dcg,{listing,"codegen"}} | asm_passes()]. @@ -771,6 +777,8 @@ asm_passes() -> {iff,drecv,{listing,"recv"}}, {unless,no_record_opt,{pass,beam_record}}, {iff,drecord,{listing,"record"}}, + {unless,no_blk2,?pass(block2)}, + {iff,dblk2,{listing,"block2"}}, {unless,no_stack_trimming,{pass,beam_trim}}, {iff,dtrim,{listing,"trim"}}, {pass,beam_flatten}]}, @@ -789,8 +797,10 @@ asm_passes() -> | binary_passes()]. binary_passes() -> - [{native_compile,fun test_native/1,fun native_compile/2}, - {unless,binary,?pass(save_binary,not_werror)}]. + [{iff,'to_dis',?pass(to_dis)}, + {native_compile,fun test_native/1,fun native_compile/2}, + {unless,binary,?pass(save_binary,not_werror)} + ]. %%% %%% Compiler passes. @@ -1128,6 +1138,16 @@ core_lint_module(Code, St) -> errors=St#compile.errors ++ Es}} end. +%% makedep + output and continue +makedep_and_output(Code0, St) -> + {ok,DepCode,St1} = makedep(Code0,St), + case makedep_output(DepCode, St1) of + {ok,_IgnoreCode,St2} -> + {ok,Code0,St2}; + {error,St2} -> + {error,St2} + end. + makedep(Code0, #compile{ifile=Ifile,ofile=Ofile,options=Opts}=St) -> %% Get the target of the Makefile rule. @@ -1334,6 +1354,10 @@ v3_kernel(Code0, #compile{options=Opts,warnings=Ws0}=St) -> {ok,Code,St} end. +block2(Code0, #compile{options=Opts}=St) -> + {ok,Code} = beam_block:module(Code0, [no_blockify|Opts]), + {ok,Code,St}. + test_old_inliner(#compile{options=Opts}) -> %% The point of this test is to avoid loading the old inliner %% if we know that it will not be used. @@ -1450,16 +1474,16 @@ beam_asm(Code0, #compile{ifile=File,extra_chunks=ExtraChunks,options=CompilerOpt {ok,DebugInfo,Opts0} -> Opts1 = [O || O <- Opts0, effects_code_generation(O)], Chunks = [{<<"Dbgi">>, DebugInfo} | ExtraChunks], - CompileInfo = compile_info(File, Opts1), + CompileInfo = compile_info(File, CompilerOpts, Opts1), {ok,Code} = beam_asm:module(Code0, Chunks, CompileInfo, CompilerOpts), {ok,Code,St#compile{abstract_code=[]}}; {error,Es} -> {error,St#compile{errors=St#compile.errors ++ [{File,Es}]}} end. -compile_info(File, Opts) -> - IsSlim = member(slim, Opts), - IsDeterministic = member(deterministic, Opts), +compile_info(File, CompilerOpts, Opts) -> + IsSlim = member(slim, CompilerOpts), + IsDeterministic = member(deterministic, CompilerOpts), Info0 = proplists:get_value(compile_info, Opts, []), Info1 = case paranoid_absname(File) of @@ -1530,15 +1554,14 @@ native_compile_1(Code, St) -> {error,St#compile{errors=St#compile.errors ++ Es}} end catch - Class:R -> - Stk = erlang:get_stacktrace(), + Class:R:Stack -> case IgnoreErrors of true -> Ws = [{St#compile.ifile, - [{none,?MODULE,{native_crash,R,Stk}}]}], + [{none,?MODULE,{native_crash,R,Stack}}]}], {ok,St#compile{warnings=St#compile.warnings ++ Ws}}; false -> - erlang:raise(Class, R, Stk) + erlang:raise(Class, R, Stack) end end. @@ -1766,6 +1789,21 @@ listing(LFun, Ext, Code, St) -> {error,St#compile{errors=St#compile.errors ++ Es}} end. +to_dis(Code, #compile{module=Module,ofile=Outfile}=St) -> + Loaded = code:is_loaded(Module), + Sticky = code:is_sticky(Module), + _ = [code:unstick_mod(Module) || Sticky], + + {module,Module} = code:load_binary(Module, "", Code), + DestDir = filename:dirname(Outfile), + DisFile = filename:join(DestDir, atom_to_list(Module) ++ ".dis"), + ok = erts_debug:dis_to_file(Module, DisFile), + + %% Restore loaded module + _ = [{module, Module} = code:load_file(Module) || Loaded =/= false], + [code:stick_mod(Module) || Sticky], + {ok,Code,St}. + output_encoding(F, #compile{encoding = none}) -> ok = io:setopts(F, [{encoding, epp:default_encoding()}]); output_encoding(F, #compile{encoding = Encoding}) -> @@ -1947,7 +1985,6 @@ pre_load() -> sys_core_fold, v3_codegen, v3_core, - v3_kernel, - v3_life], + v3_kernel], _ = code:ensure_modules_loaded(L), ok. diff --git a/lib/compiler/src/compiler.app.src b/lib/compiler/src/compiler.app.src index 703cf1d1b8..cf32fd251c 100644 --- a/lib/compiler/src/compiler.app.src +++ b/lib/compiler/src/compiler.app.src @@ -68,8 +68,7 @@ v3_codegen, v3_core, v3_kernel, - v3_kernel_pp, - v3_life + v3_kernel_pp ]}, {registered, []}, {applications, [kernel, stdlib]}, diff --git a/lib/compiler/src/core_lint.erl b/lib/compiler/src/core_lint.erl index 7d3513c0ba..6e2114be56 100644 --- a/lib/compiler/src/core_lint.erl +++ b/lib/compiler/src/core_lint.erl @@ -353,12 +353,6 @@ expr(#c_case{arg=Arg,clauses=Cs}, Def, Rt, St0) -> Pc = case_patcount(Cs), St1 = body(Arg, Def, Pc, St0), clauses(Cs, Def, Pc, Rt, St1); -expr(#c_receive{clauses=Cs,timeout=#c_literal{val=infinity}, - action=#c_literal{}}, - Def, Rt, St) -> - %% If the timeout is 'infinity', the after code can never - %% be reached. We don't care if the return count is wrong. - clauses(Cs, Def, 1, Rt, St); expr(#c_receive{clauses=Cs,timeout=T,action=A}, Def, Rt, St0) -> St1 = expr(T, Def, 1, St0), St2 = body(A, Def, Rt, St1), diff --git a/lib/compiler/src/genop.tab b/lib/compiler/src/genop.tab index b5688de339..a47d4e8cf7 100755 --- a/lib/compiler/src/genop.tab +++ b/lib/compiler/src/genop.tab @@ -545,3 +545,32 @@ BEAM_FORMAT_NUMBER=0 ## Test the arity of Reg and jumps to Lbl if it is not N. ## Test the first element of the tuple and jumps to Lbl if it is not Atom. 159: is_tagged_tuple/4 + +# OTP 21 + +## @spec build_stacktrace +## @doc Given the raw stacktrace in x(0), build a cooked stacktrace suitable +## for human consumption. Store it in x(0). Destroys all other registers. +## Do a garbage collection if necessary to allocate space on the heap +## for the result. +160: build_stacktrace/0 + +## @spec raw_raise +## @doc This instruction works like the erlang:raise/3 BIF, except that the +## stacktrace in x(2) must be a raw stacktrace. +## x(0) is the class of the exception (error, exit, or throw), +## x(1) is the exception term, and x(2) is the raw stackframe. +## If x(0) is not a valid class, the instruction will not throw an +## exception, but store the atom 'badarg' in x(0) and execute the +## next instruction. +161: raw_raise/0 + +## @spec get_hd Source Head +## @doc Get the head (or car) part of a list (a cons cell) from Source and +## put it into the register Head. +162: get_hd/2 + +## @spec get_tl Source Tail +## @doc Get the tail (or cdr) part of a list (a cons cell) from Source and +## put it into the register Tail. +163: get_tl/2 diff --git a/lib/compiler/src/sys_core_alias.erl b/lib/compiler/src/sys_core_alias.erl index 63e2f7488e..1bce1577d1 100644 --- a/lib/compiler/src/sys_core_alias.erl +++ b/lib/compiler/src/sys_core_alias.erl @@ -64,8 +64,7 @@ def({#c_var{name={F,Arity}}=Name,B0}) -> erase(new_var_num), {Name,B1} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [F,Arity]), erlang:raise(Class, Error, Stack) end. diff --git a/lib/compiler/src/sys_core_bsm.erl b/lib/compiler/src/sys_core_bsm.erl index 3e04cc33df..65580f79e3 100644 --- a/lib/compiler/src/sys_core_bsm.erl +++ b/lib/compiler/src/sys_core_bsm.erl @@ -24,7 +24,7 @@ -export([module/2,format_error/1]). -include("core_parse.hrl"). --import(lists, [member/2,nth/2,reverse/1,usort/1]). +-import(lists, [member/2,reverse/1,usort/1]). -spec module(cerl:c_module(), [compile:option()]) -> {'ok', cerl:c_module()}. @@ -44,8 +44,7 @@ function([{#c_var{name={F,Arity}}=Name,B0}|Fs], FsAcc, Ws0) -> {B,Ws} -> function(Fs, [{Name,B}|FsAcc], Ws) catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [F,Arity]), erlang:raise(Class, Error, Stack) end; @@ -60,13 +59,6 @@ format_error(bin_opt_alias) -> format_error(bin_partition) -> "INFO: matching non-variables after a previous clause matching a variable " "will prevent delayed sub binary optimization"; -format_error(bin_left_var_used_in_guard) -> - "INFO: a variable to the left of the binary pattern is used in a guard; " - "will prevent delayed sub binary optimization"; -format_error(bin_argument_order) -> - "INFO: matching anything else but a plain variable to the left of " - "binary pattern will prevent delayed sub binary optimization; " - "SUGGEST changing argument order"; format_error(bin_var_used) -> "INFO: using a matched out sub binary will prevent " "delayed sub binary optimization"; @@ -97,46 +89,41 @@ bsm_an(#c_case{arg=#c_values{es=Es}}=Case) -> bsm_an(Other) -> {ok,Other}. -bsm_an_1(Vs, #c_case{clauses=Cs}=Case) -> - case bsm_leftmost(Cs) of - none -> {ok,Case}; - Pos -> bsm_an_2(Vs, Cs, Case, Pos) - end. - -bsm_an_2(Vs, Cs, Case, Pos) -> - case bsm_nonempty(Cs, Pos) of - true -> bsm_an_3(Vs, Cs, Case, Pos); - false -> {ok,Case} +bsm_an_1(Vs0, #c_case{clauses=Cs0}=Case) -> + case bsm_leftmost(Cs0) of + none -> + {ok,Case}; + 1 -> + bsm_an_2(Vs0, Cs0, Case); + Pos -> + Vs = move_from_col(Pos, Vs0), + Cs = [C#c_clause{pats=move_from_col(Pos, Ps)} || + #c_clause{pats=Ps}=C <- Cs0], + bsm_an_2(Vs, Cs, Case) end. -bsm_an_3(Vs, Cs, Case, Pos) -> +bsm_an_2(Vs, Cs, Case) -> try - bsm_ensure_no_partition(Cs, Pos), - {ok,bsm_do_an(Vs, Pos, Cs, Case)} + bsm_ensure_no_partition(Cs), + {ok,bsm_do_an(Vs, Cs, Case)} catch - throw:{problem,Where,What} -> - {ok,Case,{Where,What}} + throw:{problem,Where,What} -> + {ok,Case,{Where,What}} end. -bsm_do_an(Vs0, Pos, Cs0, Case) -> - case nth(Pos, Vs0) of - #c_var{name=Vname}=V0 -> - Cs = bsm_do_an_var(Vname, Pos, Cs0, []), - V = bsm_annotate_for_reuse(V0), - Bef = lists:sublist(Vs0, Pos-1), - Aft = lists:nthtail(Pos, Vs0), - case Bef ++ [V|Aft] of - [_] -> - Case#c_case{arg=V,clauses=Cs}; - Vs -> - Case#c_case{arg=#c_values{es=Vs},clauses=Cs} - end; - _ -> - Case - end. +move_from_col(Pos, L) -> + {First,[Col|Rest]} = lists:split(Pos - 1, L), + [Col|First] ++ Rest. -bsm_do_an_var(V, S, [#c_clause{pats=Ps,guard=G,body=B0}=C0|Cs], Acc) -> - case nth(S, Ps) of +bsm_do_an([#c_var{name=Vname}=V0|Vs0], Cs0, Case) -> + Cs = bsm_do_an_var(Vname, Cs0), + V = bsm_annotate_for_reuse(V0), + Vs = core_lib:make_values([V|Vs0]), + Case#c_case{arg=Vs,clauses=Cs}; +bsm_do_an(_Vs, _Cs, Case) -> Case. + +bsm_do_an_var(V, [#c_clause{pats=[P|_],guard=G,body=B0}=C0|Cs]) -> + case P of #c_var{name=VarName} -> case core_lib:is_var_used(V, G) of true -> bsm_problem(C0, orig_bin_var_used_in_guard); @@ -149,23 +136,23 @@ bsm_do_an_var(V, S, [#c_clause{pats=Ps,guard=G,body=B0}=C0|Cs], Acc) -> B1 = bsm_maybe_ctx_to_binary(VarName, B0), B = bsm_maybe_ctx_to_binary(V, B1), C = C0#c_clause{body=B}, - bsm_do_an_var(V, S, Cs, [C|Acc]); - #c_alias{}=P -> + [C|bsm_do_an_var(V, Cs)]; + #c_alias{} -> case bsm_could_match_binary(P) of false -> - bsm_do_an_var(V, S, Cs, [C0|Acc]); + [C0|bsm_do_an_var(V, Cs)]; true -> bsm_problem(C0, bin_opt_alias) end; - P -> + _ -> case bsm_could_match_binary(P) andalso bsm_is_var_used(V, G, B0) of false -> - bsm_do_an_var(V, S, Cs, [C0|Acc]); + [C0|bsm_do_an_var(V, Cs)]; true -> bsm_problem(C0, bin_var_used) end end; -bsm_do_an_var(_, _, [], Acc) -> reverse(Acc). +bsm_do_an_var(_, []) -> []. bsm_annotate_for_reuse(#c_var{anno=Anno}=Var) -> Var#c_var{anno=[reuse_for_context|Anno]}. @@ -193,131 +180,82 @@ previous_ctx_to_binary(V, Core) -> end. %% bsm_leftmost(Cs) -> none | ArgumentNumber -%% Find the leftmost argument that does binary matching. Return -%% the number of the argument (1-N). +%% Find the leftmost argument that matches a nonempty binary. +%% Return either 'none' or the argument number (1-N). bsm_leftmost(Cs) -> bsm_leftmost_1(Cs, none). +bsm_leftmost_1([_|_], 1) -> + 1; bsm_leftmost_1([#c_clause{pats=Ps}|Cs], Pos) -> bsm_leftmost_2(Ps, Cs, 1, Pos); bsm_leftmost_1([], Pos) -> Pos. bsm_leftmost_2(_, Cs, Pos, Pos) -> bsm_leftmost_1(Cs, Pos); -bsm_leftmost_2([#c_binary{}|_], Cs, N, _) -> +bsm_leftmost_2([#c_binary{segments=[_|_]}|_], Cs, N, _) -> bsm_leftmost_1(Cs, N); bsm_leftmost_2([_|Ps], Cs, N, Pos) -> bsm_leftmost_2(Ps, Cs, N+1, Pos); bsm_leftmost_2([], Cs, _, Pos) -> bsm_leftmost_1(Cs, Pos). -%% bsm_nonempty(Cs, Pos) -> true|false -%% Check if at least one of the clauses matches a non-empty -%% binary in the given argument position. +%% bsm_ensure_no_partition(Cs) -> ok (exception if problem) +%% There must only be a single bs_start_match2 instruction if we +%% are to reuse the binary variable for the match context. +%% +%% To make sure that there is only a single bs_start_match2 +%% instruction, we will check for partitions such as: %% -bsm_nonempty([#c_clause{pats=Ps}|Cs], Pos) -> - case nth(Pos, Ps) of - #c_binary{segments=[_|_]} -> - true; - _ -> - bsm_nonempty(Cs, Pos) - end; -bsm_nonempty([], _ ) -> false. - -%% bsm_ensure_no_partition(Cs, Pos) -> ok (exception if problem) -%% We must make sure that matching is not partitioned between -%% variables like this: %% foo(<<...>>) -> ... %% foo(<Variable>) when ... -> ... -%% foo(<Any non-variable pattern>) -> -%% If there is such partition, we are not allowed to reuse the binary variable -%% for the match context. +%% foo(<Non-variable pattern>) -> %% -%% Also, arguments to the left of the argument that is matched -%% against a binary, are only allowed to be simple variables, not -%% used in guards. The reason is that we must know that the binary is -%% only matched in one place (i.e. there must be only one bs_start_match2 -%% instruction emitted). +%% If there is such partition, we reject the optimization. -bsm_ensure_no_partition(Cs, Pos) -> - bsm_ensure_no_partition_1(Cs, Pos, before). +bsm_ensure_no_partition(Cs) -> + bsm_ensure_no_partition_1(Cs, before). %% Loop through each clause. -bsm_ensure_no_partition_1([#c_clause{pats=Ps,guard=G}|Cs], Pos, State0) -> - State = bsm_ensure_no_partition_2(Ps, Pos, G, simple_vars, State0), +bsm_ensure_no_partition_1([#c_clause{pats=Ps,guard=G}|Cs], State0) -> + State = bsm_ensure_no_partition_2(Ps, G, State0), case State of 'after' -> - bsm_ensure_no_partition_after(Cs, Pos); + bsm_ensure_no_partition_after(Cs); _ -> ok end, - bsm_ensure_no_partition_1(Cs, Pos, State); -bsm_ensure_no_partition_1([], _, _) -> ok. + bsm_ensure_no_partition_1(Cs, State); +bsm_ensure_no_partition_1([], _) -> ok. -%% Loop through each pattern for this clause. -bsm_ensure_no_partition_2([#c_binary{}=Where|_], 1, _, Vstate, State) -> - case State of - before when Vstate =:= simple_vars -> within; - before -> bsm_problem(Where, Vstate); - within when Vstate =:= simple_vars -> within; - within -> bsm_problem(Where, Vstate) - end; -bsm_ensure_no_partition_2([#c_alias{}=Alias|_], 1, N, Vstate, State) -> +bsm_ensure_no_partition_2([#c_binary{}|_], _, _State) -> + within; +bsm_ensure_no_partition_2([#c_alias{}=Alias|_], N, State) -> %% Retrieve the real pattern that the alias refers to and check that. P = bsm_real_pattern(Alias), - bsm_ensure_no_partition_2([P], 1, N, Vstate, State); -bsm_ensure_no_partition_2([_|_], 1, _, _Vstate, before=State) -> + bsm_ensure_no_partition_2([P], N, State); +bsm_ensure_no_partition_2([_|_], _, before=State) -> %% No binary matching yet - therefore no partition. State; -bsm_ensure_no_partition_2([P|_], 1, _, Vstate, State) -> +bsm_ensure_no_partition_2([P|_], _, State) -> case bsm_could_match_binary(P) of false -> - %% If clauses can be freely arranged (Vstate =:= simple_vars), - %% a clause that cannot match a binary will not partition the clause. - %% Example: - %% - %% a(Var, <<>>) -> ... - %% a(Var, []) -> ... - %% a(Var, <<B>>) -> ... - %% - %% But if the clauses can't be freely rearranged, as in - %% - %% b(Var, <<X>>) -> ... - %% b(1, 2) -> ... - %% - %% we do have a problem. - %% - case Vstate of - simple_vars -> State; - _ -> bsm_problem(P, Vstate) - end; + State; true -> %% The pattern P *may* match a binary, so we must update the state. %% (P must be a variable.) - case State of - within -> 'after'; - 'after' -> 'after' - end - end; -bsm_ensure_no_partition_2([#c_var{name=V}|Ps], N, G, Vstate, S) -> - case core_lib:is_var_used(V, G) of - false -> - bsm_ensure_no_partition_2(Ps, N-1, G, Vstate, S); - true -> - bsm_ensure_no_partition_2(Ps, N-1, G, bin_left_var_used_in_guard, S) - end; -bsm_ensure_no_partition_2([_|Ps], N, G, _, S) -> - bsm_ensure_no_partition_2(Ps, N-1, G, bin_argument_order, S). + 'after' + end. -bsm_ensure_no_partition_after([#c_clause{pats=Ps}=C|Cs], Pos) -> - case nth(Pos, Ps) of - #c_var{} -> - bsm_ensure_no_partition_after(Cs, Pos); - _ -> - bsm_problem(C, bin_partition) +bsm_ensure_no_partition_after([#c_clause{pats=Ps}=C|Cs]) -> + case Ps of + [#c_var{}|_] -> + bsm_ensure_no_partition_after(Cs); + _ -> + bsm_problem(C, bin_partition) end; -bsm_ensure_no_partition_after([], _) -> ok. +bsm_ensure_no_partition_after([]) -> ok. bsm_could_match_binary(#c_alias{pat=P}) -> bsm_could_match_binary(P); bsm_could_match_binary(#c_cons{}) -> false; diff --git a/lib/compiler/src/sys_core_dsetel.erl b/lib/compiler/src/sys_core_dsetel.erl index bd3eeae238..9e2df69b33 100644 --- a/lib/compiler/src/sys_core_dsetel.erl +++ b/lib/compiler/src/sys_core_dsetel.erl @@ -81,8 +81,7 @@ visit_module_1([{Name,F0}|Fs], Env, Acc) -> {F,_} -> visit_module_1(Fs, Env, [{Name,F}|Acc]) catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> #c_var{name={Func,Arity}} = Name, io:fwrite("Function: ~w/~w\n", [Func,Arity]), erlang:raise(Class, Error, Stack) diff --git a/lib/compiler/src/sys_core_fold.erl b/lib/compiler/src/sys_core_fold.erl index df880ff784..a9bd363ee1 100644 --- a/lib/compiler/src/sys_core_fold.erl +++ b/lib/compiler/src/sys_core_fold.erl @@ -125,8 +125,7 @@ function_1({#c_var{name={F,Arity}}=Name,B0}) -> end, B0, 20), {Name,B} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [F,Arity]), erlang:raise(Class, Error, Stack) end. @@ -146,14 +145,9 @@ find_fixpoint(OptFun, Core0, Max) -> body(Body, Sub) -> body(Body, value, Sub). -body(#c_values{anno=A,es=Es0}, Ctxt, Sub) -> - Es1 = expr_list(Es0, Ctxt, Sub), - case Ctxt of - value -> - #c_values{anno=A,es=Es1}; - effect -> - make_effect_seq(Es1, Sub) - end; +body(#c_values{anno=A,es=Es0}, value, Sub) -> + Es1 = expr_list(Es0, value, Sub), + #c_values{anno=A,es=Es1}; body(E, Ctxt, Sub) -> ?ASSERT(verify_scope(E, Sub)), expr(E, Ctxt, Sub). @@ -314,9 +308,15 @@ expr(#c_seq{arg=Arg0,body=B0}=Seq0, Ctxt, Sub) -> false -> %% Arg cannot be "values" here - only a single value %% make sense here. - case is_safe_simple(Arg, Sub) of - true -> B1; - false -> Seq0#c_seq{arg=Arg,body=B1} + case {Ctxt,is_safe_simple(Arg, Sub)} of + {effect,true} -> B1; + {effect,false} -> + case is_safe_simple(B1, Sub) of + true -> Arg; + false -> Seq0#c_seq{arg=Arg,body=B1} + end; + {value,true} -> B1; + {value,false} -> Seq0#c_seq{arg=Arg,body=B1} end end; expr(#c_let{}=Let0, Ctxt, Sub) -> @@ -380,10 +380,7 @@ expr(#c_case{}=Case0, Ctxt, Sub) -> Case = Case1#c_case{arg=Arg2,clauses=Cs2}, warn_no_clause_match(Case1, Case), Expr = eval_case(Case, Sub), - case move_case_into_arg(Case, Sub) of - impossible -> Expr; - Other -> Other - end; + move_case_into_arg(Expr, Sub); Other -> expr(Other, Ctxt, Sub) end; @@ -415,6 +412,8 @@ expr(#c_call{module=M0,name=N0}=Call0, Ctxt, Sub) -> no -> call(Call, M1, N1, Sub); {yes,Seq} -> expr(Seq, Ctxt, Sub) end; +expr(#c_primop{name=#c_literal{val=build_stacktrace}}, effect, _Sub) -> + void(); expr(#c_primop{args=As0}=Prim, _, Sub) -> As1 = expr_list(As0, value, Sub), Prim#c_primop{args=As1}; @@ -2508,6 +2507,72 @@ are_all_failing_clauses(Cs) -> is_failing_clause(#c_clause{body=B}) -> will_fail(B). +%% opt_build_stacktrace(Let) -> Core. +%% If the stacktrace is *only* used in a call to erlang:raise/3, +%% there is no need to build a cooked stackframe using build_stacktrace/1. + +opt_build_stacktrace(#c_let{vars=[#c_var{name=Cooked}], + arg=#c_primop{name=#c_literal{val=build_stacktrace}, + args=[RawStk]}, + body=Body}=Let) -> + case Body of + #c_call{module=#c_literal{val=erlang}, + name=#c_literal{val=raise}, + args=[Class,Exp,#c_var{name=Cooked}]} -> + %% The stacktrace is only used in a call to erlang:raise/3. + %% There is no need to build the stacktrace. Replace the + %% call to erlang:raise/3 with the the raw_raise/3 instruction, + %% which will use a raw stacktrace. + #c_primop{name=#c_literal{val=raw_raise}, + args=[Class,Exp,RawStk]}; + #c_let{vars=[#c_var{name=V}],arg=Arg,body=B0} when V =/= Cooked -> + case core_lib:is_var_used(Cooked, Arg) of + false -> + %% The built stacktrace is not used in the argument, + %% so we can sink the building of the stacktrace into + %% the body of the let. + B = opt_build_stacktrace(Let#c_let{body=B0}), + Body#c_let{body=B}; + true -> + Let + end; + #c_seq{arg=Arg,body=B0} -> + case core_lib:is_var_used(Cooked, Arg) of + false -> + %% The built stacktrace is not used in the argument, + %% so we can sink the building of the stacktrace into + %% the body of the sequence. + B = opt_build_stacktrace(Let#c_let{body=B0}), + Body#c_seq{body=B}; + true -> + Let + end; + #c_case{arg=Arg,clauses=Cs0} -> + case core_lib:is_var_used(Cooked, Arg) orelse + is_used_in_any_guard(Cooked, Cs0) of + false -> + %% The built stacktrace is not used in the argument, + %% so we can sink the building of the stacktrace into + %% each arm of the case. + Cs = [begin + B = opt_build_stacktrace(Let#c_let{body=B0}), + C#c_clause{body=B} + end || #c_clause{body=B0}=C <- Cs0], + Body#c_case{clauses=Cs}; + true -> + Let + end; + _ -> + Let + end; +opt_build_stacktrace(Expr) -> + Expr. + +is_used_in_any_guard(V, Cs) -> + any(fun(#c_clause{guard=G}) -> + core_lib:is_var_used(V, G) + end, Cs). + %% opt_case_in_let(Let) -> Let' %% Try to avoid building tuples that are immediately matched. %% A common pattern is: @@ -2622,9 +2687,13 @@ delay_build_expr_1(#c_receive{clauses=Cs0, timeout=Timeout, action=A0}=Rec, TypeSig) -> Cs = delay_build_cs(Cs0, TypeSig), - A = case Timeout of - #c_literal{val=infinity} -> A0; - _ -> delay_build_expr(A0, TypeSig) + A = case {Timeout,A0} of + {#c_literal{val=infinity},#c_literal{}} -> + {_Type,Arity} = TypeSig, + Es = lists:duplicate(Arity, A0), + core_lib:make_values(Es); + _ -> + delay_build_expr(A0, TypeSig) end, Rec#c_receive{clauses=Cs,action=A}; delay_build_expr_1(#c_seq{body=B0}=Seq, TypeSig) -> @@ -2659,53 +2728,94 @@ opt_simple_let_1(#c_let{vars=Vs0,body=B0}=Let, Arg0, Ctxt, Sub0) -> %% Optimise let and add new substitutions. {Vs,Args,Sub1} = let_substs(Vs0, Arg0, Sub0), BodySub = update_let_types(Vs, Args, Sub1), + Sub = Sub1#sub{v=[],s=cerl_sets:new()}, B = body(B0, Ctxt, BodySub), Arg = core_lib:make_values(Args), - opt_simple_let_2(Let, Vs, Arg, B, B0, Ctxt, Sub1). + opt_simple_let_2(Let, Vs, Arg, B, B0, Sub). + -opt_simple_let_2(Let0, Vs0, Arg0, Body, PrevBody, Ctxt, Sub) -> +%% opt_simple_let_2(Let0, Vs0, Arg0, Body, PrevBody, Ctxt, Sub) -> Core. +%% Do final simplifications of the let. +%% +%% Note that the substitutions and scope in Sub have been cleared +%% and should not be used. + +opt_simple_let_2(Let0, Vs0, Arg0, Body, PrevBody, Sub) -> case {Vs0,Arg0,Body} of - {[#c_var{name=N1}],Arg1,#c_var{name=N2}} -> - case N1 =:= N2 of - true -> - %% let <Var> = Arg in <Var> ==> Arg - Arg1; - false -> - %% let <Var> = Arg in <OtherVar> ==> seq Arg OtherVar - Arg = maybe_suppress_warnings(Arg1, Vs0, PrevBody), - #c_seq{arg=Arg,body=Body} - end; + {[#c_var{name=V}],Arg1,#c_var{name=V}} -> + %% let <Var> = Arg in <Var> ==> Arg + Arg1; {[],#c_values{es=[]},_} -> %% No variables left. Body; - {Vs,Arg1,#c_literal{}} -> - Arg = maybe_suppress_warnings(Arg1, Vs, PrevBody), - case Ctxt of - effect -> - %% Throw away the literal body. - Arg; - value -> - %% Since the variable is not used in the body, we - %% can rewrite the let to a sequence. - %% let <Var> = Arg in Literal ==> seq Arg Literal - #c_seq{arg=Arg,body=Body} - end; - {Vs,Arg1,Body} -> - %% If none of the variables are used in the body, we can - %% rewrite the let to a sequence: - %% let <Var> = Arg in BodyWithoutVar ==> - %% seq Arg BodyWithoutVar - case is_any_var_used(Vs, Body) of - false -> - Arg = maybe_suppress_warnings(Arg1, Vs, PrevBody), - #c_seq{arg=Arg,body=Body}; - true -> - Let1 = Let0#c_let{vars=Vs,arg=Arg1,body=Body}, - opt_bool_case_in_let(Let1, Sub) + {[#c_var{name=V}=Var|Vars]=Vars0,Arg1,Body} -> + case core_lib:is_var_used(V, Body) of + false when Vars =:= [] -> + %% If the variable is not used in the body, we can + %% rewrite the let to a sequence: + %% let <Var> = Arg in BodyWithoutVar ==> + %% seq Arg BodyWithoutVar + Arg = maybe_suppress_warnings(Arg1, Var, PrevBody), + #c_seq{arg=Arg,body=Body}; + false -> + %% There are multiple values returned by the argument + %% and the first value is not used (this is a 'case' + %% with exported variables, but the return value is + %% ignored). We can remove the first variable and the + %% the first value returned from the 'let' argument. + Arg2 = remove_first_value(Arg1, Sub), + Let1 = Let0#c_let{vars=Vars,arg=Arg2,body=Body}, + post_opt_let(Let1, Sub); + true -> + Let1 = Let0#c_let{vars=Vars0,arg=Arg1,body=Body}, + post_opt_let(Let1, Sub) end end. -%% maybe_suppress_warnings(Arg, [#c_var{}], PreviousBody) -> Arg' +%% post_opt_let(Let, Sub) +%% Final optimizations of the let. +%% +%% Note that the substitutions and scope in Sub have been cleared +%% and should not be used. + +post_opt_let(Let0, Sub) -> + Let1 = opt_bool_case_in_let(Let0, Sub), + opt_build_stacktrace(Let1). + + +%% remove_first_value(Core0, Sub) -> Core. +%% Core0 is an expression that returns at least two values. +%% Remove the first value returned from Core0. + +remove_first_value(#c_values{es=[V|Vs]}, Sub) -> + Values = core_lib:make_values(Vs), + case is_safe_simple(V, Sub) of + false -> + #c_seq{arg=V,body=Values}; + true -> + Values + end; +remove_first_value(#c_case{clauses=Cs0}=Core, Sub) -> + Cs = remove_first_value_cs(Cs0, Sub), + Core#c_case{clauses=Cs}; +remove_first_value(#c_receive{clauses=Cs0,action=Act0}=Core, Sub) -> + Cs = remove_first_value_cs(Cs0, Sub), + Act = remove_first_value(Act0, Sub), + Core#c_receive{clauses=Cs,action=Act}; +remove_first_value(#c_let{body=B}=Core, Sub) -> + Core#c_let{body=remove_first_value(B, Sub)}; +remove_first_value(#c_seq{body=B}=Core, Sub) -> + Core#c_seq{body=remove_first_value(B, Sub)}; +remove_first_value(#c_primop{}=Core, _Sub) -> + Core; +remove_first_value(#c_call{}=Core, _Sub) -> + Core. + +remove_first_value_cs(Cs, Sub) -> + [C#c_clause{body=remove_first_value(B, Sub)} || + #c_clause{body=B}=C <- Cs]. + +%% maybe_suppress_warnings(Arg, #c_var{}, PreviousBody) -> Arg' %% Try to suppress false warnings when a variable is not used. %% For instance, we don't expect a warning for useless building in: %% @@ -2716,12 +2826,12 @@ opt_simple_let_2(Let0, Vs0, Arg0, Body, PrevBody, Ctxt, Sub) -> %% referenced in the original unoptimized code. If they were, we will %% consider the warning false and suppress it. -maybe_suppress_warnings(Arg, Vs, PrevBody) -> +maybe_suppress_warnings(Arg, #c_var{name=V}, PrevBody) -> case should_suppress_warning(Arg) of true -> Arg; %Already suppressed. false -> - case is_any_var_used(Vs, PrevBody) of + case core_lib:is_var_used(V, PrevBody) of true -> suppress_warning([Arg]); false -> @@ -2810,7 +2920,7 @@ move_case_into_arg(#c_case{arg=#c_case{arg=OuterArg, Outer#c_case{arg=OuterArg, clauses=[OuterCa,OuterCb]}; false -> - impossible + Inner0 end; move_case_into_arg(#c_case{arg=#c_seq{arg=OuterArg,body=InnerArg}=Outer, clauses=InnerClauses}=Inner, _Sub) -> @@ -2826,15 +2936,8 @@ move_case_into_arg(#c_case{arg=#c_seq{arg=OuterArg,body=InnerArg}=Outer, %% Outer#c_seq{arg=OuterArg, body=Inner#c_case{arg=InnerArg,clauses=InnerClauses}}; -move_case_into_arg(_, _) -> - impossible. - -is_any_var_used([#c_var{name=V}|Vs], Expr) -> - case core_lib:is_var_used(V, Expr) of - false -> is_any_var_used(Vs, Expr); - true -> true - end; -is_any_var_used([], _) -> false. +move_case_into_arg(Expr, _) -> + Expr. %%% %%% Retrieving information about types. diff --git a/lib/compiler/src/v3_codegen.erl b/lib/compiler/src/v3_codegen.erl index ee5bafbc5c..a8f4926e55 100644 --- a/lib/compiler/src/v3_codegen.erl +++ b/lib/compiler/src/v3_codegen.erl @@ -19,25 +19,6 @@ %% %% Purpose : Code generator for Beam. -%% The following assumptions have been made: -%% -%% 1. Matches, i.e. things with {match,M,Ret} wrappers, only return -%% values; no variables are exported. If the match would have returned -%% extra variables then these have been transformed to multiple return -%% values. -%% -%% 2. All BIF's called in guards are gc-safe so there is no need to -%% put thing on the stack in the guard. While this would in principle -%% work it would be difficult to keep track of the stack depth when -%% trimming. -%% -%% The code generation uses variable lifetime information added by -%% the v3_life module to save variables, allocate registers and -%% move registers to the stack when necessary. -%% -%% We try to use a consistent variable name scheme throughout. The -%% StackReg record is always called Bef,Int<n>,Aft. - -module(v3_codegen). %% The main interface. @@ -45,12 +26,14 @@ -import(lists, [member/2,keymember/3,keysort/2,keydelete/3, append/1,flatmap/2,filter/2,foldl/3,foldr/3,mapfoldl/3, - sort/1,reverse/1,reverse/2]). --import(v3_life, [vdb_find/2]). + sort/1,reverse/1,reverse/2,map/2]). +-import(ordsets, [add_element/2,intersection/2,union/2]). -%%-compile([export_all]). +-include("v3_kernel.hrl"). --include("v3_life.hrl"). +%% These are not defined in v3_kernel.hrl. +get_kanno(Kthing) -> element(2, Kthing). +set_kanno(Kthing, Anno) -> setelement(2, Kthing, Anno). %% Main codegen structure. -record(cg, {lcount=1, %Label counter @@ -61,38 +44,400 @@ functable=#{}, %Map of local functions: {Name,Arity}=>Label in_catch=false, %Inside a catch or not. need_frame, %Need a stack frame. - ultimate_failure %Label for ultimate match failure. - }). + ultimate_failure, %Label for ultimate match failure. + ctx %Match context. + }). %% Stack/register state record. -record(sr, {reg=[], %Register table stk=[], %Stack table - res=[]}). %Reserved regs: [{reserved,I,V}] + res=[]}). %Registers to reserve + +%% Internal records. +-record(cg_need_heap, {anno=[] :: term(), + h=0 :: integer()}). +-record(cg_block, {anno=[] :: term(), + es=[] :: [term()]}). --type life_module() :: {module(),_,_,[_]}. +-type vdb_entry() :: {atom(),non_neg_integer(),non_neg_integer()}. --spec module(life_module(), [compile:option()]) -> {'ok',beam_asm:module_code()}. +-record(l, {i=0 :: non_neg_integer(), %Op number + vdb=[] :: [vdb_entry()], %Variable database + a=[] :: [term()]}). %Core annotation -module({Mod,Exp,Attr,Forms}, _Options) -> - {Fs,St} = functions(Forms, {atom,Mod}), - {ok,{Mod,Exp,Attr,Fs,St#cg.lcount}}. +-spec module(#k_mdef{}, [compile:option()]) -> {'ok',beam_asm:module_code()}. + +module(#k_mdef{name=Mod,exports=Es,attributes=Attr,body=Forms}, _Opts) -> + {Asm,St} = functions(Forms, {atom,Mod}), + {ok,{Mod,Es,Attr,Asm,St#cg.lcount}}. functions(Forms, AtomMod) -> mapfoldl(fun (F, St) -> function(F, AtomMod, St) end, #cg{lcount=1}, Forms). -function({function,Name,Arity,Asm0,Vb,Vdb,Anno}, AtomMod, St0) -> +function(#k_fdef{anno=#k{a=Anno},func=Name,arity=Arity, + vars=As,body=Kb}, AtomMod, St0) -> + try + #k_match{} = Kb, %Assertion. + + %% Try to suppress the stack frame unless it is + %% really needed. + Body0 = avoid_stack_frame(Kb), + + %% Annotate kernel records with variable usage. + Vdb0 = init_vars(As), + {Body,_,Vdb} = body(Body0, 1, Vdb0), + + %% Generate the BEAM assembly code. + {Asm,EntryLabel,St} = cg_fun(Body, As, Vdb, AtomMod, + {Name,Arity}, Anno, St0), + Func = {function,Name,Arity,EntryLabel,Asm}, + {Func,St} + catch + Class:Error:Stack -> + io:fwrite("Function: ~w/~w\n", [Name,Arity]), + erlang:raise(Class, Error, Stack) + end. + + +%% avoid_stack_frame(Kernel) -> Kernel' +%% If possible, avoid setting up a stack frame. Functions +%% that only do matching, calls to guard BIFs, and tail-recursive +%% calls don't need a stack frame. + +avoid_stack_frame(#k_match{body=Body}=M) -> try - {Asm,EntryLabel,St} = cg_fun(Vb, Asm0, Vdb, AtomMod, - {Name,Arity}, Anno, St0), - Func = {function,Name,Arity,EntryLabel,Asm}, - {Func,St} + M#k_match{body=avoid_stack_frame_1(Body)} catch - Class:Error -> - Stack = erlang:get_stacktrace(), - io:fwrite("Function: ~w/~w\n", [Name,Arity]), - erlang:raise(Class, Error, Stack) + impossible -> + M end. +avoid_stack_frame_1(#k_alt{first=First0,then=Then0}=Alt) -> + First = avoid_stack_frame_1(First0), + Then = avoid_stack_frame_1(Then0), + Alt#k_alt{first=First,then=Then}; +avoid_stack_frame_1(#k_bif{op=Op}=Bif) -> + case Op of + #k_internal{} -> + %% Most internal BIFs clobber the X registers. + throw(impossible); + _ -> + Bif + end; +avoid_stack_frame_1(#k_break{anno=Anno,args=Args}) -> + #k_guard_break{anno=Anno,args=Args}; +avoid_stack_frame_1(#k_guard_break{}=Break) -> + Break; +avoid_stack_frame_1(#k_enter{}=Enter) -> + %% Tail-recursive calls don't need a stack frame. + Enter; +avoid_stack_frame_1(#k_guard{clauses=Cs0}=Guard) -> + Cs = avoid_stack_frame_list(Cs0), + Guard#k_guard{clauses=Cs}; +avoid_stack_frame_1(#k_guard_clause{guard=G0,body=B0}=C) -> + G = avoid_stack_frame_1(G0), + B = avoid_stack_frame_1(B0), + C#k_guard_clause{guard=G,body=B}; +avoid_stack_frame_1(#k_match{anno=A,vars=Vs,body=B0,ret=Ret}) -> + %% Use #k_guard_match{} instead to avoid saving the X registers + %% to the stack before matching. + B = avoid_stack_frame_1(B0), + #k_guard_match{anno=A,vars=Vs,body=B,ret=Ret}; +avoid_stack_frame_1(#k_guard_match{body=B0}=M) -> + B = avoid_stack_frame_1(B0), + M#k_guard_match{body=B}; +avoid_stack_frame_1(#k_protected{arg=Arg0}=Prot) -> + Arg = avoid_stack_frame_1(Arg0), + Prot#k_protected{arg=Arg}; +avoid_stack_frame_1(#k_put{}=Put) -> + Put; +avoid_stack_frame_1(#k_return{}=Ret) -> + Ret; +avoid_stack_frame_1(#k_select{var=#k_var{anno=Vanno},types=Types0}=Select) -> + case member(reuse_for_context, Vanno) of + false -> + Types = avoid_stack_frame_list(Types0), + Select#k_select{types=Types}; + true -> + %% Including binary patterns that overwrite the register containing + %% the binary with the match context may not be safe. For example, + %% bs_match_SUITE:bin_tail_e/1 with inlining will be rejected by + %% beam_validator. + %% + %% Essentially the following code is produced: + %% + %% bs_match {x,0} => {x,0} + %% ... + %% bs_match {x,0} => {x,1} %% ILLEGAL + %% + %% A bs_match instruction will only accept a match context as the + %% source operand if the source and destination registers are the + %% the same (as in the first bs_match instruction above). + %% The second bs_match instruction is therefore illegal. + %% + %% This situation is avoided if there is a stack frame: + %% + %% move {x,0} => {y,0} + %% bs_match {x,0} => {x,0} + %% ... + %% bs_match {y,0} => {x,1} %% LEGAL + %% + throw(impossible) + end; +avoid_stack_frame_1(#k_seq{arg=#k_call{anno=Anno,op=Op}=Call, + body=#k_break{args=BrArgs0}}=Seq) -> + case Op of + #k_remote{mod=#k_atom{val=Mod}, + name=#k_atom{val=Name}, + arity=Arity} -> + case erl_bifs:is_exit_bif(Mod, Name, Arity) of + false -> + %% Will clobber X registers. Must have a stack frame. + throw(impossible); + true -> + %% The call to this BIF will never return. It is safe + %% to suppress the stack frame. + Bif = #k_bif{anno=Anno, + op=#k_internal{name=guard_error,arity=1}, + args=[Call],ret=[]}, + BrArgs = lists:duplicate(length(BrArgs0), #k_nil{}), + GB = #k_guard_break{anno=#k{us=[],ns=[],a=[]},args=BrArgs}, + Seq#k_seq{arg=Bif,body=GB} + end; + _ -> + %% Will clobber X registers. Must have a stack frame. + throw(impossible) + end; +avoid_stack_frame_1(#k_seq{arg=A0,body=B0}=Seq) -> + A = avoid_stack_frame_1(A0), + B = avoid_stack_frame_1(B0), + Seq#k_seq{arg=A,body=B}; +avoid_stack_frame_1(#k_test{}=Test) -> + Test; +avoid_stack_frame_1(#k_type_clause{values=Values0}=TC) -> + Values = avoid_stack_frame_list(Values0), + TC#k_type_clause{values=Values}; +avoid_stack_frame_1(#k_val_clause{body=B0}=VC) -> + B = avoid_stack_frame_1(B0), + VC#k_val_clause{body=B}; +avoid_stack_frame_1(_Body) -> + throw(impossible). + +avoid_stack_frame_list([H|T]) -> + [avoid_stack_frame_1(H)|avoid_stack_frame_list(T)]; +avoid_stack_frame_list([]) -> []. + + +%% This pass creates beam format annotated with variable lifetime +%% information. Each thing is given an index and for each variable we +%% store the first and last index for its occurrence. The variable +%% database, VDB, attached to each thing is only relevant internally +%% for that thing. +%% +%% For nested things like matches the numbering continues locally and +%% the VDB for that thing refers to the variable usage within that +%% thing. Variables which live through a such a thing are internally +%% given a very large last index. Internally the indexes continue +%% after the index of that thing. This creates no problems as the +%% internal variable info never escapes and externally we only see +%% variable which are alive both before or after. +%% +%% This means that variables never "escape" from a thing and the only +%% way to get values from a thing is to "return" them, with 'break' or +%% 'return'. Externally these values become the return values of the +%% thing. This is no real limitation as most nested things have +%% multiple threads so working out a common best variable usage is +%% difficult. + +%% body(Kbody, I, Vdb) -> {[Expr],MaxI,Vdb}. +%% Handle a body. + +body(#k_seq{arg=Ke,body=Kb}, I, Vdb0) -> + %%ok = io:fwrite("life ~w:~p~n", [?LINE,{Ke,I,Vdb0}]), + A = get_kanno(Ke), + Vdb1 = use_vars(union(A#k.us, A#k.ns), I, Vdb0), + {Es,MaxI,Vdb2} = body(Kb, I+1, Vdb1), + E = expr(Ke, I, Vdb2), + {[E|Es],MaxI,Vdb2}; +body(Ke, I, Vdb0) -> + %%ok = io:fwrite("life ~w:~p~n", [?LINE,{Ke,I,Vdb0}]), + A = get_kanno(Ke), + Vdb1 = use_vars(union(A#k.us, A#k.ns), I, Vdb0), + E = expr(Ke, I, Vdb1), + {[E],I,Vdb1}. + +%% expr(Kexpr, I, Vdb) -> Expr. + +expr(#k_test{anno=A}=Test, I, _Vdb) -> + Test#k_test{anno=#l{i=I,a=A#k.a}}; +expr(#k_call{anno=A}=Call, I, _Vdb) -> + Call#k_call{anno=#l{i=I,a=A#k.a}}; +expr(#k_enter{anno=A}=Enter, I, _Vdb) -> + Enter#k_enter{anno=#l{i=I,a=A#k.a}}; +expr(#k_bif{anno=A}=Bif, I, _Vdb) -> + Bif#k_bif{anno=#l{i=I,a=A#k.a}}; +expr(#k_match{anno=A,body=Kb,ret=Rs}, I, Vdb) -> + %% Work out imported variables which need to be locked. + Mdb = vdb_sub(I, I+1, Vdb), + M = match(Kb, A#k.us, I+1, Mdb), + L = #l{i=I,vdb=use_vars(A#k.us, I+1, Mdb),a=A#k.a}, + #k_match{anno=L,body=M,ret=Rs}; +expr(#k_guard_match{anno=A,body=Kb,ret=Rs}, I, Vdb) -> + %% Work out imported variables which need to be locked. + Mdb = vdb_sub(I, I+1, Vdb), + M = match(Kb, A#k.us, I+1, Mdb), + L = #l{i=I,vdb=use_vars(A#k.us, I+1, Mdb),a=A#k.a}, + #k_guard_match{anno=L,body=M,ret=Rs}; +expr(#k_protected{}=Protected, I, Vdb) -> + protected(Protected, I, Vdb); +expr(#k_try{anno=A,arg=Ka,vars=Vs,body=Kb,evars=Evs,handler=Kh}=Try, I, Vdb) -> + %% Lock variables that are alive before the catch and used afterwards. + %% Don't lock variables that are only used inside the try. + Tdb0 = vdb_sub(I, I+1, Vdb), + %% This is the tricky bit. Lock variables in Arg that are used in + %% the body and handler. Add try tag 'variable'. + Ab = get_kanno(Kb), + Ah = get_kanno(Kh), + Tdb1 = use_vars(union(Ab#k.us, Ah#k.us), I+3, Tdb0), + Tdb2 = vdb_sub(I, I+2, Tdb1), + Vnames = fun (Kvar) -> Kvar#k_var.name end, %Get the variable names + {Aes,_,Adb} = body(Ka, I+2, add_var({catch_tag,I+1}, I+1, locked, Tdb2)), + {Bes,_,Bdb} = body(Kb, I+4, new_vars(sort(map(Vnames, Vs)), I+3, Tdb2)), + {Hes,_,Hdb} = body(Kh, I+4, new_vars(sort(map(Vnames, Evs)), I+3, Tdb2)), + L = #l{i=I,vdb=Tdb1,a=A#k.a}, + Try#k_try{anno=L, + arg=#cg_block{es=Aes,anno=#l{i=I+1,vdb=Adb,a=[]}}, + vars=Vs,body=#cg_block{es=Bes,anno=#l{i=I+3,vdb=Bdb,a=[]}}, + evars=Evs,handler=#cg_block{es=Hes,anno=#l{i=I+3,vdb=Hdb,a=[]}}}; +expr(#k_try_enter{anno=A,arg=Ka,vars=Vs,body=Kb,evars=Evs,handler=Kh}, I, Vdb) -> + %% Lock variables that are alive before the catch and used afterwards. + %% Don't lock variables that are only used inside the try. + Tdb0 = vdb_sub(I, I+1, Vdb), + %% This is the tricky bit. Lock variables in Arg that are used in + %% the body and handler. Add try tag 'variable'. + Ab = get_kanno(Kb), + Ah = get_kanno(Kh), + Tdb1 = use_vars(union(Ab#k.us, Ah#k.us), I+3, Tdb0), + Tdb2 = vdb_sub(I, I+2, Tdb1), + Vnames = fun (Kvar) -> Kvar#k_var.name end, %Get the variable names + {Aes,_,Adb} = body(Ka, I+2, add_var({catch_tag,I+1}, I+1, 1000000, Tdb2)), + {Bes,_,Bdb} = body(Kb, I+4, new_vars(sort(map(Vnames, Vs)), I+3, Tdb2)), + {Hes,_,Hdb} = body(Kh, I+4, new_vars(sort(map(Vnames, Evs)), I+3, Tdb2)), + L = #l{i=I,vdb=Tdb1,a=A#k.a}, + #k_try_enter{anno=L, + arg=#cg_block{es=Aes,anno=#l{i=I+1,vdb=Adb,a=[]}}, + vars=Vs,body=#cg_block{es=Bes,anno=#l{i=I+3,vdb=Bdb,a=[]}}, + evars=Evs,handler=#cg_block{es=Hes,anno=#l{i=I+3,vdb=Hdb,a=[]}}}; +expr(#k_catch{anno=A,body=Kb}=Catch, I, Vdb) -> + %% Lock variables that are alive before the catch and used afterwards. + %% Don't lock variables that are only used inside the catch. + %% Add catch tag 'variable'. + Cdb0 = vdb_sub(I, I+1, Vdb), + {Es,_,Cdb1} = body(Kb, I+1, add_var({catch_tag,I}, I, locked, Cdb0)), + L = #l{i=I,vdb=Cdb1,a=A#k.a}, + Catch#k_catch{anno=L,body=#cg_block{es=Es}}; +expr(#k_receive{anno=A,var=V,body=Kb,action=Ka}=Recv, I, Vdb) -> + %% Work out imported variables which need to be locked. + Rdb = vdb_sub(I, I+1, Vdb), + M = match(Kb, add_element(V#k_var.name, A#k.us), I+1, + new_vars([V#k_var.name], I, Rdb)), + {Tes,_,Adb} = body(Ka, I+1, Rdb), + Le = #l{i=I,vdb=use_vars(A#k.us, I+1, Vdb),a=A#k.a}, + Recv#k_receive{anno=Le,body=M, + action=#cg_block{anno=#l{i=I+1,vdb=Adb,a=[]},es=Tes}}; +expr(#k_receive_accept{anno=A}, I, _Vdb) -> + #k_receive_accept{anno=#l{i=I,a=A#k.a}}; +expr(#k_receive_next{anno=A}, I, _Vdb) -> + #k_receive_next{anno=#l{i=I,a=A#k.a}}; +expr(#k_put{anno=A}=Put, I, _Vdb) -> + Put#k_put{anno=#l{i=I,a=A#k.a}}; +expr(#k_break{anno=A}=Break, I, _Vdb) -> + Break#k_break{anno=#l{i=I,a=A#k.a}}; +expr(#k_guard_break{anno=A}=Break, I, _Vdb) -> + Break#k_guard_break{anno=#l{i=I,a=A#k.a}}; +expr(#k_return{anno=A}=Ret, I, _Vdb) -> + Ret#k_return{anno=#l{i=I,a=A#k.a}}. + +%% protected(Kprotected, I, Vdb) -> Protected. +%% Only used in guards. + +protected(#k_protected{anno=A,arg=Ts}=Prot, I, Vdb) -> + %% Lock variables that are alive before try and used afterwards. + %% Don't lock variables that are only used inside the protected + %% expression. + Pdb0 = vdb_sub(I, I+1, Vdb), + {T,MaxI,Pdb1} = body(Ts, I+1, Pdb0), + Pdb2 = use_vars(A#k.ns, MaxI+1, Pdb1), %Save "return" values + Prot#k_protected{arg=T,anno=#l{i=I,a=A#k.a,vdb=Pdb2}}. + +%% match(Kexpr, [LockVar], I, Vdb) -> Expr. +%% Convert match tree to old format. + +match(#k_alt{anno=A,first=Kf,then=Kt}, Ls, I, Vdb0) -> + Vdb1 = use_vars(union(A#k.us, Ls), I, Vdb0), + F = match(Kf, Ls, I+1, Vdb1), + T = match(Kt, Ls, I+1, Vdb1), + #k_alt{anno=[],first=F,then=T}; +match(#k_select{anno=A,types=Kts}=Select, Ls, I, Vdb0) -> + Vdb1 = use_vars(union(A#k.us, Ls), I, Vdb0), + Ts = [type_clause(Tc, Ls, I+1, Vdb1) || Tc <- Kts], + Select#k_select{anno=[],types=Ts}; +match(#k_guard{anno=A,clauses=Kcs}, Ls, I, Vdb0) -> + Vdb1 = use_vars(union(A#k.us, Ls), I, Vdb0), + Cs = [guard_clause(G, Ls, I+1, Vdb1) || G <- Kcs], + #k_guard{anno=[],clauses=Cs}; +match(Other, Ls, I, Vdb0) -> + Vdb1 = use_vars(Ls, I, Vdb0), + {B,_,Vdb2} = body(Other, I+1, Vdb1), + Le = #l{i=I,vdb=Vdb2,a=[]}, + #cg_block{anno=Le,es=B}. + +type_clause(#k_type_clause{anno=A,type=T,values=Kvs}, Ls, I, Vdb0) -> + %%ok = io:format("life ~w: ~p~n", [?LINE,{T,Kvs}]), + Vdb1 = use_vars(union(A#k.us, Ls), I+1, Vdb0), + Vs = [val_clause(Vc, Ls, I+1, Vdb1) || Vc <- Kvs], + #k_type_clause{anno=[],type=T,values=Vs}. + +val_clause(#k_val_clause{anno=A,val=V,body=Kb}, Ls0, I, Vdb0) -> + New = (get_kanno(V))#k.ns, + Bus = (get_kanno(Kb))#k.us, + %%ok = io:format("Ls0 = ~p, Used=~p\n New=~p, Bus=~p\n", [Ls0,Used,New,Bus]), + Ls1 = union(intersection(New, Bus), Ls0), %Lock for safety + Vdb1 = use_vars(union(A#k.us, Ls1), I+1, new_vars(New, I, Vdb0)), + B = match(Kb, Ls1, I+1, Vdb1), + Le = #l{i=I,vdb=use_vars(Bus, I+1, Vdb1),a=A#k.a}, + #k_val_clause{anno=Le,val=V,body=B}. + +guard_clause(#k_guard_clause{anno=A,guard=Kg,body=Kb}, Ls, I, Vdb0) -> + Vdb1 = use_vars(union(A#k.us, Ls), I+2, Vdb0), + Gdb = vdb_sub(I+1, I+2, Vdb1), + G = protected(Kg, I+1, Gdb), + B = match(Kb, Ls, I+2, Vdb1), + Le = #l{i=I,vdb=use_vars((get_kanno(Kg))#k.us, I+2, Vdb1),a=A#k.a}, + #k_guard_clause{anno=Le,guard=G,body=B}. + + +%% Here follows the code generator pass. +%% +%% The following assumptions have been made: +%% +%% 1. Matches, i.e. things with {match,M,Ret} wrappers, only return +%% values; no variables are exported. If the match would have returned +%% extra variables then these have been transformed to multiple return +%% values. +%% +%% 2. All BIF's called in guards are gc-safe so there is no need to +%% put thing on the stack in the guard. While this would in principle +%% work it would be difficult to keep track of the stack depth when +%% trimming. +%% +%% The code generation uses variable lifetime information added by +%% the previous pass to save variables, allocate registers and +%% move registers to the stack when necessary. +%% +%% We try to use a consistent variable name scheme throughout. The +%% StackReg record is always called Bef,Int<n>,Aft. + %% cg_fun([Lkexpr], [HeadVar], Vdb, State) -> {[Ainstr],State} cg_fun(Les, Hvs, Vdb, AtomMod, NameArity, Anno, St0) -> @@ -114,18 +459,18 @@ cg_fun(Les, Hvs, Vdb, AtomMod, NameArity, Anno, St0) -> %% Note that and 'if_end' instruction does not need any %% live x registers, so it will always be safe to jump to %% it. (We never ever expect the jump to be taken, and in - %% must functions there will never be any references to + %% most functions there will never be any references to %% the label in the first place.) %% {UltimateMatchFail,St3} = new_label(St2), %% Create initial stack/register state, clear unused arguments. - Bef = clear_dead(#sr{reg=foldl(fun ({var,V}, Reg) -> + Bef = clear_dead(#sr{reg=foldl(fun (#k_var{name=V}, Reg) -> put_reg(V, Reg) end, [], Hvs), stk=[]}, 0, Vdb), - {B,_Aft,St} = cg_list(Les, 0, Vdb, Bef, + {B,_Aft,St} = cg_list(Les, Vdb, Bef, St3#cg{bfail=0, ultimate_failure=UltimateMatchFail, is_top_block=true}), @@ -136,66 +481,64 @@ cg_fun(Les, Hvs, Vdb, AtomMod, NameArity, Anno, St0) -> %% cg(Lkexpr, Vdb, StackReg, State) -> {[Ainstr],StackReg,State}. %% Generate code for a kexpr. -%% Split function into two steps for clarity, not efficiency. -cg(Le, Vdb, Bef, St) -> - cg(Le#l.ke, Le, Vdb, Bef, St). - -cg({block,Es}, Le, Vdb, Bef, St) -> +cg(#cg_block{anno=Le,es=Es}, Vdb, Bef, St) -> block_cg(Es, Le, Vdb, Bef, St); -cg({match,M,Rs}, Le, Vdb, Bef, St) -> +cg(#k_match{anno=Le,body=M,ret=Rs}, Vdb, Bef, St) -> match_cg(M, Rs, Le, Vdb, Bef, St); -cg({guard_match,M,Rs}, Le, Vdb, Bef, St) -> +cg(#k_guard_match{anno=Le,body=M,ret=Rs}, Vdb, Bef, St) -> guard_match_cg(M, Rs, Le, Vdb, Bef, St); -cg({call,Func,As,Rs}, Le, Vdb, Bef, St) -> +cg(#k_call{anno=Le,op=Func,args=As,ret=Rs}, Vdb, Bef, St) -> call_cg(Func, As, Rs, Le, Vdb, Bef, St); -cg({enter,Func,As}, Le, Vdb, Bef, St) -> +cg(#k_enter{anno=Le,op=Func,args=As}, Vdb, Bef, St) -> enter_cg(Func, As, Le, Vdb, Bef, St); -cg({bif,Bif,As,Rs}, Le, Vdb, Bef, St) -> - bif_cg(Bif, As, Rs, Le, Vdb, Bef, St); -cg({gc_bif,Bif,As,Rs}, Le, Vdb, Bef, St) -> - gc_bif_cg(Bif, As, Rs, Le, Vdb, Bef, St); -cg({internal,Bif,As,Rs}, Le, Vdb, Bef, St) -> - internal_cg(Bif, As, Rs, Le, Vdb, Bef, St); -cg({receive_loop,Te,Rvar,Rm,Tes,Rs}, Le, Vdb, Bef, St) -> +cg(#k_bif{anno=Le}=Bif, Vdb, Bef, St) -> + bif_cg(Bif, Le, Vdb, Bef, St); +cg(#k_receive{anno=Le,timeout=Te,var=Rvar,body=Rm,action=Tes,ret=Rs}, + Vdb, Bef, St) -> recv_loop_cg(Te, Rvar, Rm, Tes, Rs, Le, Vdb, Bef, St); -cg(receive_next, Le, Vdb, Bef, St) -> +cg(#k_receive_next{anno=Le}, Vdb, Bef, St) -> recv_next_cg(Le, Vdb, Bef, St); -cg(receive_accept, _Le, _Vdb, Bef, St) -> {[remove_message],Bef,St}; -cg({'try',Ta,Vs,Tb,Evs,Th,Rs}, Le, Vdb, Bef, St) -> +cg(#k_receive_accept{}, _Vdb, Bef, St) -> + {[remove_message],Bef,St}; +cg(#k_try{anno=Le,arg=Ta,vars=Vs,body=Tb,evars=Evs,handler=Th,ret=Rs}, + Vdb, Bef, St) -> try_cg(Ta, Vs, Tb, Evs, Th, Rs, Le, Vdb, Bef, St); -cg({try_enter,Ta,Vs,Tb,Evs,Th}, Le, Vdb, Bef, St) -> +cg(#k_try_enter{anno=Le,arg=Ta,vars=Vs,body=Tb,evars=Evs,handler=Th}, + Vdb, Bef, St) -> try_enter_cg(Ta, Vs, Tb, Evs, Th, Le, Vdb, Bef, St); -cg({'catch',Cb,R}, Le, Vdb, Bef, St) -> +cg(#k_catch{anno=Le,body=Cb,ret=[R]}, Vdb, Bef, St) -> catch_cg(Cb, R, Le, Vdb, Bef, St); -cg({set,Var,Con}, Le, Vdb, Bef, St) -> - set_cg(Var, Con, Le, Vdb, Bef, St); -cg({return,Rs}, Le, Vdb, Bef, St) -> return_cg(Rs, Le, Vdb, Bef, St); -cg({break,Bs}, Le, Vdb, Bef, St) -> break_cg(Bs, Le, Vdb, Bef, St); -cg({guard_break,Bs,N}, Le, Vdb, Bef, St) -> - guard_break_cg(Bs, N, Le, Vdb, Bef, St); -cg({need_heap,H}, _Le, _Vdb, Bef, St) -> +cg(#k_put{anno=Le,arg=Con,ret=Var}, Vdb, Bef, St) -> + put_cg(Var, Con, Le, Vdb, Bef, St); +cg(#k_return{anno=Le,args=Rs}, Vdb, Bef, St) -> + return_cg(Rs, Le, Vdb, Bef, St); +cg(#k_break{anno=Le,args=Bs}, Vdb, Bef, St) -> + break_cg(Bs, Le, Vdb, Bef, St); +cg(#k_guard_break{anno=Le,args=Bs}, Vdb, Bef, St) -> + guard_break_cg(Bs, Le, Vdb, Bef, St); +cg(#cg_need_heap{h=H}, _Vdb, Bef, St) -> {[{test_heap,H,max_reg(Bef#sr.reg)}],Bef,St}. %% cg_list([Kexpr], FirstI, Vdb, StackReg, St) -> {[Ainstr],StackReg,St}. -cg_list(Kes, I, Vdb, Bef, St0) -> +cg_list(Kes, Vdb, Bef, St0) -> {Keis,{Aft,St1}} = flatmapfoldl(fun (Ke, {Inta,Sta}) -> {Keis,Intb,Stb} = cg(Ke, Vdb, Inta, Sta), {Keis,{Intb,Stb}} - end, {Bef,St0}, need_heap(Kes, I)), + end, {Bef,St0}, need_heap(Kes)), {Keis,Aft,St1}. %% need_heap([Lkexpr], I, St) -> [Lkexpr]. %% Insert need_heap instructions in Kexpr list. Try to be smart and %% collect them together as much as possible. -need_heap(Kes0, I) -> +need_heap(Kes0) -> {Kes,H} = need_heap_0(reverse(Kes0), 0, []), %% Prepend need_heap if necessary. - need_heap_need(I, H) ++ Kes. + need_heap_need(H) ++ Kes. need_heap_0([Ke|Kes], H0, Acc) -> {Ns,H} = need_heap_1(Ke, H0), @@ -203,27 +546,54 @@ need_heap_0([Ke|Kes], H0, Acc) -> need_heap_0([], H, Acc) -> {Acc,H}. -need_heap_1(#l{ke={set,_,{binary,_}},i=I}, H) -> - {need_heap_need(I, H),0}; -need_heap_1(#l{ke={set,_,{map,_,_,_}},i=I}, H) -> - {need_heap_need(I, H),0}; -need_heap_1(#l{ke={set,_,Val}}, H) -> +need_heap_1(#k_put{arg=#k_binary{}}, H) -> + {need_heap_need(H),0}; +need_heap_1(#k_put{arg=#k_map{}}, H) -> + {need_heap_need(H),0}; +need_heap_1(#k_put{arg=Val}, H) -> %% Just pass through adding to needed heap. {[],H + case Val of - {cons,_} -> 2; - {tuple,Es} -> 1 + length(Es); + #k_cons{} -> 2; + #k_tuple{es=Es} -> 1 + length(Es); _Other -> 0 end}; -need_heap_1(#l{ke={bif,_Bif,_As,_Rs}}, H) -> - {[],H}; -need_heap_1(#l{i=I}, H) -> +need_heap_1(#k_bif{}=Bif, H) -> + case is_gc_bif(Bif) of + false -> + {[],H}; + true -> + {need_heap_need(H),0} + end; +need_heap_1(_Ke, H) -> %% Call or call-like instruction such as set_tuple_element/3. - {need_heap_need(I, H),0}. - -need_heap_need(_I, 0) -> []; -need_heap_need(I, H) -> [#l{ke={need_heap,H},i=I}]. - -%% match_cg(Match, [Ret], Le, Vdb, StackReg, State) -> + {need_heap_need(H),0}. + +need_heap_need(0) -> []; +need_heap_need(H) -> [#cg_need_heap{h=H}]. + +%% is_gc_bif(#k_bif{}) -> true|false. +%% is_gc_bif(Name, Arity) -> true|false. +%% Determines whether the BIF Name/Arity might do a GC. + +is_gc_bif(#k_bif{op=#k_remote{name=#k_atom{val=Name}},args=Args}) -> + is_gc_bif(Name, length(Args)); +is_gc_bif(#k_bif{op=#k_internal{}}) -> + true. + +is_gc_bif(hd, 1) -> false; +is_gc_bif(tl, 1) -> false; +is_gc_bif(self, 0) -> false; +is_gc_bif(node, 0) -> false; +is_gc_bif(node, 1) -> false; +is_gc_bif(element, 2) -> false; +is_gc_bif(get, 1) -> false; +is_gc_bif(tuple_size, 1) -> false; +is_gc_bif(Bif, Arity) -> + not (erl_internal:bool_op(Bif, Arity) orelse + erl_internal:new_type_test(Bif, Arity) orelse + erl_internal:comp_op(Bif, Arity)). + +%% match_cg(Matc, [Ret], Le, Vdb, StackReg, State) -> %% {[Ainstr],StackReg,State}. %% Generate code for a match. First save all variables on the stack %% that are to survive after the match. We leave saved variables in @@ -244,7 +614,10 @@ match_cg(M, Rs, Le, Vdb, Bef, St0) -> guard_match_cg(M, Rs, Le, Vdb, Bef, St0) -> I = Le#l.i, {B,St1} = new_label(St0), - #cg{bfail=Fail} = St1, + Fail = case St0 of + #cg{bfail=0,ultimate_failure=Fail0} -> Fail0; + #cg{bfail=Fail0} -> Fail0 + end, {Mis,Aft,St2} = match_cg(M, Fail, Bef, St1#cg{break=B}), %% Update the register descriptors for the return registers. Reg = guard_match_regs(Aft#sr.reg, Rs), @@ -252,7 +625,7 @@ guard_match_cg(M, Rs, Le, Vdb, Bef, St0) -> clear_dead(Aft#sr{reg=Reg}, I, Vdb), St2#cg{break=St1#cg.break}}. -guard_match_regs([{I,gbreakvar}|Rs], [{var,V}|Vs]) -> +guard_match_regs([{I,gbreakvar}|Rs], [#k_var{name=V}|Vs]) -> [{I,V}|guard_match_regs(Rs, Vs)]; guard_match_regs([R|Rs], Vs) -> [R|guard_match_regs(Rs, Vs)]; @@ -264,17 +637,14 @@ guard_match_regs([], []) -> []. %% down as each level which uses this takes its own internal Vdb not %% the outer one. -match_cg(Le, Fail, Bef, St) -> - match_cg(Le#l.ke, Le, Fail, Bef, St). - -match_cg({alt,F,S}, _Le, Fail, Bef, St0) -> +match_cg(#k_alt{first=F,then=S}, Fail, Bef, St0) -> {Tf,St1} = new_label(St0), {Fis,Faft,St2} = match_cg(F, Tf, Bef, St1), {Sis,Saft,St3} = match_cg(S, Fail, Bef, St2), Aft = sr_merge(Faft, Saft), {Fis ++ [{label,Tf}] ++ Sis,Aft,St3}; -match_cg({select,{var,Vname}=V,Scs0}, #l{a=Anno}, Fail, Bef, St) -> - ReuseForContext = member(reuse_for_context, Anno) andalso +match_cg(#k_select{var=#k_var{anno=Vanno,name=Vname}=V,types=Scs0}, Fail, Bef, St) -> + ReuseForContext = member(reuse_for_context, Vanno) andalso find_reg(Vname, Bef#sr.reg) =/= error, Scs = case ReuseForContext of false -> Scs0; @@ -283,10 +653,10 @@ match_cg({select,{var,Vname}=V,Scs0}, #l{a=Anno}, Fail, Bef, St) -> match_fmf(fun (S, F, Sta) -> select_cg(S, V, F, Fail, Bef, Sta) end, Fail, St, Scs); -match_cg({guard,Gcs}, _Le, Fail, Bef, St) -> +match_cg(#k_guard{clauses=Gcs}, Fail, Bef, St) -> match_fmf(fun (G, F, Sta) -> guard_clause_cg(G, F, Bef, Sta) end, Fail, St, Gcs); -match_cg({block,Es}, Le, _Fail, Bef, St) -> +match_cg(#cg_block{anno=Le,es=Es}, _Fail, Bef, St) -> %% Must clear registers and stack of dead variables. Int = clear_dead(Bef, Le#l.i, Le#l.vdb), block_cg(Es, Le, Int, St). @@ -294,8 +664,8 @@ match_cg({block,Es}, Le, _Fail, Bef, St) -> %% bsm_rename_ctx([Clause], Var) -> [Clause] %% We know from an annotation that the register for a binary can %% be reused for the match context because the two are not truly -%% alive at the same time (even though the conservative life time -%% information calculated by v3_life says so). +%% alive at the same time (even though the life time information +%% says so). %% %% The easiest way to have those variables share the same register is %% to rename the variable with the shortest life-span (the match @@ -306,12 +676,14 @@ match_cg({block,Es}, Le, _Fail, Bef, St) -> %% We must also remove all information about the match context %% variable from all life-time information databases (Vdb). -bsm_rename_ctx([#l{ke={type_clause,binary, - [#l{ke={val_clause,{binary,{var,Old}},Ke0}}=L2]}}=L1|Cs], New) -> +bsm_rename_ctx([#k_type_clause{type=k_binary,values=Vcs}=TC|Cs], New) -> + [#k_val_clause{val=#k_binary{segs=#k_var{name=Old}}=Bin, + body=Ke0}=VC0] = Vcs, Ke = bsm_rename_ctx(Ke0, Old, New, false), - [L1#l{ke={type_clause,binary, - [L2#l{ke={val_clause,{binary,{var,New}},Ke}}]}}|bsm_rename_ctx(Cs, New)]; -bsm_rename_ctx([C|Cs], New) -> + VC = VC0#k_val_clause{val=Bin#k_binary{segs=#k_var{name=New}}, + body=Ke}, + [TC#k_type_clause{values=[VC]}|bsm_rename_ctx(Cs, New)]; +bsm_rename_ctx([C|Cs], New) -> [C|bsm_rename_ctx(Cs, New)]; bsm_rename_ctx([], _) -> []. @@ -321,34 +693,24 @@ bsm_rename_ctx([], _) -> []. %% only complicatate things to recurse into blocks not in a protected %% (the match context variable is not live inside them). -bsm_rename_ctx(#l{ke={select,{var,V},Cs0}}=L, Old, New, InProt) -> +bsm_rename_ctx(#k_select{var=#k_var{name=V},types=Cs0}=Sel, + Old, New, InProt) -> Cs = bsm_rename_ctx_list(Cs0, Old, New, InProt), - L#l{ke={select,{var,bsm_rename_var(V, Old, New)},Cs}}; -bsm_rename_ctx(#l{ke={type_clause,Type,Cs0}}=L, Old, New, InProt) -> + Sel#k_select{var=#k_var{name=bsm_rename_var(V, Old, New)},types=Cs}; +bsm_rename_ctx(#k_type_clause{values=Cs0}=TC, Old, New, InProt) -> Cs = bsm_rename_ctx_list(Cs0, Old, New, InProt), - L#l{ke={type_clause,Type,Cs}}; -bsm_rename_ctx(#l{ke={val_clause,{bin_end,V},Ke0}}=L, Old, New, InProt) -> - Ke = bsm_rename_ctx(Ke0, Old, New, InProt), - L#l{ke={val_clause,{bin_end,bsm_rename_var(V, Old, New)},Ke}}; -bsm_rename_ctx(#l{ke={val_clause,{bin_seg,V,Sz,U,Type,Fl,Vs},Ke0}}=L, - Old, New, InProt) -> - Ke = bsm_rename_ctx(Ke0, Old, New, InProt), - L#l{ke={val_clause,{bin_seg,bsm_rename_var(V, Old, New),Sz,U,Type,Fl,Vs},Ke}}; -bsm_rename_ctx(#l{ke={val_clause,{bin_int,V,Sz,U,Fl,Val,Vs},Ke0}}=L, - Old, New, InProt) -> + TC#k_type_clause{values=Cs}; +bsm_rename_ctx(#k_val_clause{body=Ke0}=VC, Old, New, InProt) -> Ke = bsm_rename_ctx(Ke0, Old, New, InProt), - L#l{ke={val_clause,{bin_int,bsm_rename_var(V, Old, New),Sz,U,Fl,Val,Vs},Ke}}; -bsm_rename_ctx(#l{ke={val_clause,Val,Ke0}}=L, Old, New, InProt) -> - Ke = bsm_rename_ctx(Ke0, Old, New, InProt), - L#l{ke={val_clause,Val,Ke}}; -bsm_rename_ctx(#l{ke={alt,F0,S0}}=L, Old, New, InProt) -> + VC#k_val_clause{body=Ke}; +bsm_rename_ctx(#k_alt{first=F0,then=S0}=Alt, Old, New, InProt) -> F = bsm_rename_ctx(F0, Old, New, InProt), S = bsm_rename_ctx(S0, Old, New, InProt), - L#l{ke={alt,F,S}}; -bsm_rename_ctx(#l{ke={guard,Gcs0}}=L, Old, New, InProt) -> + Alt#k_alt{first=F,then=S}; +bsm_rename_ctx(#k_guard{clauses=Gcs0}=Guard, Old, New, InProt) -> Gcs = bsm_rename_ctx_list(Gcs0, Old, New, InProt), - L#l{ke={guard,Gcs}}; -bsm_rename_ctx(#l{ke={guard_clause,G0,B0}}=L, Old, New, InProt) -> + Guard#k_guard{clauses=Gcs}; +bsm_rename_ctx(#k_guard_clause{guard=G0,body=B0}=GC, Old, New, InProt) -> G = bsm_rename_ctx(G0, Old, New, InProt), B = bsm_rename_ctx(B0, Old, New, InProt), %% A guard clause may cause unsaved variables to be saved on the stack. @@ -356,49 +718,45 @@ bsm_rename_ctx(#l{ke={guard_clause,G0,B0}}=L, Old, New, InProt) -> %% same register), it is neither in the stack nor register descriptor %% lists and we would crash when we didn't find it unless we remove %% it from the database. - bsm_forget_var(L#l{ke={guard_clause,G,B}}, Old); -bsm_rename_ctx(#l{ke={protected,Ts0,Rs}}=L, Old, New, _InProt) -> + bsm_forget_var(GC#k_guard_clause{guard=G,body=B}, Old); +bsm_rename_ctx(#k_protected{arg=Ts0}=Prot, Old, New, _InProt) -> InProt = true, Ts = bsm_rename_ctx_list(Ts0, Old, New, InProt), - bsm_forget_var(L#l{ke={protected,Ts,Rs}}, Old); -bsm_rename_ctx(#l{ke={match,Ms0,Rs}}=L, Old, New, InProt) -> - Ms = bsm_rename_ctx(Ms0, Old, New, InProt), - L#l{ke={match,Ms,Rs}}; -bsm_rename_ctx(#l{ke={guard_match,Ms0,Rs}}=L, Old, New, InProt) -> + bsm_forget_var(Prot#k_protected{arg=Ts}, Old); +bsm_rename_ctx(#k_guard_match{body=Ms0}=Match, Old, New, InProt) -> Ms = bsm_rename_ctx(Ms0, Old, New, InProt), - L#l{ke={guard_match,Ms,Rs}}; -bsm_rename_ctx(#l{ke={test,_,_,_}}=L, _, _, _) -> L; -bsm_rename_ctx(#l{ke={bif,_,_,_}}=L, _, _, _) -> L; -bsm_rename_ctx(#l{ke={gc_bif,_,_,_}}=L, _, _, _) -> L; -bsm_rename_ctx(#l{ke={set,_,_}}=L, _, _, _) -> L; -bsm_rename_ctx(#l{ke={call,_,_,_}}=L, _, _, _) -> L; -bsm_rename_ctx(#l{ke={block,_}}=L, Old, _, false) -> + Match#k_guard_match{body=Ms}; +bsm_rename_ctx(#k_test{}=Test, _, _, _) -> Test; +bsm_rename_ctx(#k_bif{}=Bif, _, _, _) -> Bif; +bsm_rename_ctx(#k_put{}=Put, _, _, _) -> Put; +bsm_rename_ctx(#k_call{}=Call, _, _, _) -> Call; +bsm_rename_ctx(#cg_block{}=Block, Old, _, false) -> %% This block is not inside a protected. The match context variable cannot %% possibly be live inside the block. - bsm_forget_var(L, Old); -bsm_rename_ctx(#l{ke={block,Bl0}}=L, Old, New, true) -> + bsm_forget_var(Block, Old); +bsm_rename_ctx(#cg_block{es=Es0}=Block, Old, New, true) -> %% A block in a protected. We must recursively rename the variable %% inside the block. - Bl = bsm_rename_ctx_list(Bl0, Old, New, true), - bsm_forget_var(L#l{ke={block,Bl}}, Old); -bsm_rename_ctx(#l{ke={guard_break,Bs,Locked0}}=L0, Old, _New, _InProt) -> - Locked = Locked0 -- [Old], - L = L0#l{ke={guard_break,Bs,Locked}}, - bsm_forget_var(L, Old). + Es = bsm_rename_ctx_list(Es0, Old, New, true), + bsm_forget_var(Block#cg_block{es=Es}, Old); +bsm_rename_ctx(#k_guard_break{}=Break, Old, _New, _InProt) -> + bsm_forget_var(Break, Old). bsm_rename_ctx_list([C|Cs], Old, New, InProt) -> [bsm_rename_ctx(C, Old, New, InProt)| bsm_rename_ctx_list(Cs, Old, New, InProt)]; bsm_rename_ctx_list([], _, _, _) -> []. - + bsm_rename_var(Old, Old, New) -> New; bsm_rename_var(V, _, _) -> V. %% bsm_forget_var(#l{}, Variable) -> #l{} %% Remove a variable from the variable life-time database. -bsm_forget_var(#l{vdb=Vdb}=L, V) -> - L#l{vdb=keydelete(V, 1, Vdb)}. +bsm_forget_var(Ke, V) -> + #l{vdb=Vdb} = L0 = get_kanno(Ke), + L = L0#l{vdb=keydelete(V, 1, Vdb)}, + set_kanno(Ke, L). %% block_cg([Kexpr], Le, Vdb, StackReg, St) -> {[Ainstr],StackReg,St}. %% block_cg([Kexpr], Le, StackReg, St) -> {[Ainstr],StackReg,St}. @@ -407,158 +765,227 @@ block_cg(Es, Le, _Vdb, Bef, St) -> block_cg(Es, Le, Bef, St). block_cg(Es, Le, Bef, #cg{is_top_block=false}=St) -> - cg_block(Es, Le#l.i, Le#l.vdb, Bef, St); -block_cg(Es, Le, Bef, St0) -> - {Is0,Aft,St} = cg_block(Es, Le#l.i, Le#l.vdb, Bef, - St0#cg{is_top_block=false,need_frame=false}), - Is = top_level_block(Is0, Aft, max_reg(Bef#sr.reg), St), - {Is,Aft,St#cg{is_top_block=true}}. - -cg_block([], _I, _Vdb, Bef, St0) -> + cg_block(Es, Le#l.vdb, Bef, St); +block_cg(Es, Le, Bef, #cg{is_top_block=true}=St0) -> + %% No stack frame has been established yet. Do we need one? + case need_stackframe(Es) of + true -> + %% We need a stack frame. Generate the code and add the + %% code for creating and deallocating the stack frame. + {Is0,Aft,St} = cg_block(Es, Le#l.vdb, Bef, + St0#cg{is_top_block=false,need_frame=false}), + Is = top_level_block(Is0, Aft, max_reg(Bef#sr.reg), St), + {Is,Aft,St#cg{is_top_block=true}}; + false -> + %% This sequence of instructions ending in a #k_match{} (a + %% 'case' or 'if') in the Erlang code does not need a + %% stack frame yet. Delay the creation (if a stack frame + %% is needed at all, it will be created inside the + %% #k_match{}). + cg_list(Es, Le#l.vdb, Bef, St0) + end. + +%% need_stackframe([Kexpr]) -> true|false. +%% Does this list of instructions need a stack frame? +%% +%% A sequence of instructions that don't clobber the X registers +%% followed by a single #k_match{} doesn't need a stack frame. + +need_stackframe([H|T]) -> + case H of + #k_bif{op=#k_internal{}} -> true; + #k_put{arg=#k_binary{}} -> true; + #k_bif{} -> need_stackframe(T); + #k_put{} -> need_stackframe(T); + #k_guard_match{} -> need_stackframe(T); + #k_match{} when T =:= [] -> false; + _ -> true + end; +need_stackframe([]) -> false. + +cg_block([], _Vdb, Bef, St0) -> {[],Bef,St0}; -cg_block(Kes0, I, Vdb, Bef, St0) -> +cg_block(Kes0, Vdb, Bef, St0) -> {Kes2,Int1,St1} = case basic_block(Kes0) of {Kes1,LastI,Args,Rest} -> - Ke = hd(Kes1), - Fb = Ke#l.i, - cg_basic_block(Kes1, Fb, LastI, Args, Vdb, Bef, St0); + cg_basic_block(Kes1, LastI, Args, Vdb, Bef, St0); {Kes1,Rest} -> - cg_list(Kes1, I, Vdb, Bef, St0) + cg_list(Kes1, Vdb, Bef, St0) end, - {Kes3,Int2,St2} = cg_block(Rest, I, Vdb, Int1, St1), + {Kes3,Int2,St2} = cg_block(Rest, Vdb, Int1, St1), {Kes2 ++ Kes3,Int2,St2}. basic_block(Kes) -> basic_block(Kes, []). -basic_block([Le|Les], Acc) -> - case collect_block(Le#l.ke) of - include -> basic_block(Les, [Le|Acc]); +basic_block([Ke|Kes], Acc) -> + case collect_block(Ke) of + include -> basic_block(Kes, [Ke|Acc]); {block_end,As} -> case Acc of [] -> - %% If the basic block does not contain any set instructions, + %% If the basic block does not contain any #k_put{} instructions, %% it serves no useful purpose to do basic block optimizations. - {[Le],Les}; + {[Ke],Kes}; _ -> - {reverse(Acc, [Le]),Le#l.i,As,Les} + #l{i=I} = get_kanno(Ke), + {reverse(Acc, [Ke]),I,As,Kes} end; - no_block -> {reverse(Acc, [Le]),Les} + no_block -> {reverse(Acc, [Ke]),Kes} end. -%% sets that may garbage collect are not allowed in basic blocks. - -collect_block({set,_,{binary,_}}) -> no_block; -collect_block({set,_,{map,_,_,_}}) -> no_block; -collect_block({set,_,_}) -> include; -collect_block({call,{var,_}=Var,As,_Rs}) -> {block_end,As++[Var]}; -collect_block({call,Func,As,_Rs}) -> {block_end,As++func_vars(Func)}; -collect_block({enter,{var,_}=Var,As})-> {block_end,As++[Var]}; -collect_block({enter,Func,As}) -> {block_end,As++func_vars(Func)}; -collect_block({return,Rs}) -> {block_end,Rs}; -collect_block({break,Bs}) -> {block_end,Bs}; -collect_block(_) -> no_block. - -func_vars({remote,M,F}) when element(1, M) =:= var; - element(1, F) =:= var -> +collect_block(#k_put{arg=Arg}) -> + %% #k_put{} instructions that may garbage collect are not allowed + %% in basic blocks. + case Arg of + #k_binary{} -> no_block; + #k_map{} -> no_block; + _ -> include + end; +collect_block(#k_call{op=Func,args=As}) -> + {block_end,As++func_vars(Func)}; +collect_block(#k_enter{op=Func,args=As}) -> + {block_end,As++func_vars(Func)}; +collect_block(#k_return{args=Rs}) -> + {block_end,Rs}; +collect_block(#k_break{args=Bs}) -> + {block_end,Bs}; +collect_block(_) -> no_block. + +func_vars(#k_var{}=Var) -> + [Var]; +func_vars(#k_remote{mod=M,name=F}) + when is_record(M, k_var); is_record(F, k_var) -> [M,F]; func_vars(_) -> []. -%% cg_basic_block([Kexpr], FirstI, LastI, As, Vdb, StackReg, State) -> +%% cg_basic_block([Kexpr], FirstI, LastI, Arguments, Vdb, StackReg, State) -> %% {[Ainstr],StackReg,State}. - -cg_basic_block(Kes, Fb, Lf, As, Vdb, Bef, St0) -> - Res = make_reservation(As, 0), - Regs0 = reserve(Res, Bef#sr.reg, Bef#sr.stk), - Stk = extend_stack(Bef, Lf, Lf+1, Vdb), - Int0 = Bef#sr{reg=Regs0,stk=Stk,res=Res}, - X0_v0 = x0_vars(As, Fb, Lf, Vdb), - {Keis,{Aft,_,St1}} = +%% +%% Do a specialized code generation for a basic block of #put{} +%% instructions (that don't do any garbage collection) followed by a +%% call, break, or return. +%% +%% 'Arguments' is a list of the variables that must be loaded into +%% consecutive X registers before the last instruction in the block. +%% The point of this specialized code generation is to try put the +%% all of the variables in 'Arguments' into the correct X register +%% to begin with, instead of putting them into the first available +%% X register and having to move them to the correct X register +%% later. +%% +%% To achieve that, we attempt to reserve the X registers that the +%% variables in 'Arguments' will need to be in when the block ends. +%% +%% To make it more likely that reservations will be successful, we +%% will try to save variables that need to be saved to the stack as +%% early as possible (if an X register needed by a variable in +%% Arguments is occupied by another variable, the value in the +%% X register can be evicted if it is saved on the stack). +%% +%% We will take care not to increase the size of stack frame compared +%% to what the standard code generator would have done (that is, to +%% save all X registers at the last possible moment). We will do that +%% by extending the stack frame to the minimal size needed to save +%% all that needs to be saved using extend_stack/4, and use +%% save_carefully/4 during code generation to only save the variables +%% that can be saved without growing the stack frame. + +cg_basic_block(Kes, Lf, As, Vdb, Bef, St0) -> + Int0 = reserve_arg_regs(As, Bef), + Int = extend_stack(Int0, Lf, Lf+1, Vdb), + {Keis,{Aft,St1}} = flatmapfoldl(fun(Ke, St) -> cg_basic_block(Ke, St, Lf, Vdb) end, - {Int0,X0_v0,St0}, need_heap(Kes, Fb)), + {Int,St0}, need_heap(Kes)), {Keis,Aft,St1}. -cg_basic_block(#l{ke={need_heap,_}}=Ke, {Inta,X0v,Sta}, _Lf, Vdb) -> - {Keis,Intb,Stb} = cg(Ke, Vdb, Inta, Sta), - {Keis, {Intb,X0v,Stb}}; -cg_basic_block(Ke, {Inta,X0_v1,Sta}, Lf, Vdb) -> - {Sis,Intb} = save_carefully(Inta, Ke#l.i, Lf+1, Vdb), - {X0_v2,Intc} = allocate_x0(X0_v1, Ke#l.i, Intb), - Intd = reserve(Intc), - {Keis,Inte,Stb} = cg(Ke, Vdb, Intd, Sta), - {Sis ++ Keis, {Inte,X0_v2,Stb}}. - -make_reservation([], _) -> []; -make_reservation([{var,V}|As], I) -> [{I,V}|make_reservation(As, I+1)]; -make_reservation([A|As], I) -> [{I,A}|make_reservation(As, I+1)]. - -reserve(Sr) -> Sr#sr{reg=reserve(Sr#sr.res, Sr#sr.reg, Sr#sr.stk)}. - -reserve([{I,V}|Rs], [free|Regs], Stk) -> [{reserved,I,V}|reserve(Rs, Regs, Stk)]; -reserve([{I,V}|Rs], [{I,V}|Regs], Stk) -> [{I,V}|reserve(Rs, Regs, Stk)]; -reserve([{I,V}|Rs], [{I,Var}|Regs], Stk) -> +cg_basic_block(#cg_need_heap{}=Ke, {Bef,St0}, _Lf, Vdb) -> + {Keis,Aft,St1} = cg(Ke, Vdb, Bef, St0), + {Keis,{Aft,St1}}; +cg_basic_block(Ke, {Bef,St0}, Lf, Vdb) -> + #l{i=I} = get_kanno(Ke), + + %% Save all we can to increase the possibility that reserving + %% registers will succeed. + {Sis,Int0} = save_carefully(Bef, I, Lf+1, Vdb), + Int1 = reserve(Int0), + {Keis,Aft,St1} = cg(Ke, Vdb, Int1, St0), + {Sis ++ Keis,{Aft,St1}}. + +%% reserve_arg_regs([Argument], Bef) -> Aft. +%% Try to reserve the X registers for all arguments. All registers +%% that we wish to reserve will be saved in Bef#sr.res. + +reserve_arg_regs(As, Bef) -> + Res = reserve_arg_regs_1(As, 0), + reserve(Bef#sr{res=Res}). + +reserve_arg_regs_1([#k_var{name=V}|As], I) -> + [{I,V}|reserve_arg_regs_1(As, I+1)]; +reserve_arg_regs_1([A|As], I) -> + [{I,A}|reserve_arg_regs_1(As, I+1)]; +reserve_arg_regs_1([], _) -> []. + +%% reserve(Bef) -> Aft. +%% Try to reserve more registers. The registers we wish to reserve +%% are found in Bef#sr.res. + +reserve(#sr{reg=Regs,stk=Stk,res=Res}=Sr) -> + Sr#sr{reg=reserve_1(Res, Regs, Stk)}. + +reserve_1([{I,V}|Rs], [free|Regs], Stk) -> + [{reserved,I,V}|reserve_1(Rs, Regs, Stk)]; +reserve_1([{I,V}|Rs], [{I,V}|Regs], Stk) -> + [{I,V}|reserve_1(Rs, Regs, Stk)]; +reserve_1([{I,V}|Rs], [{I,Var}|Regs], Stk) -> case on_stack(Var, Stk) of - true -> [{reserved,I,V}|reserve(Rs, Regs, Stk)]; - false -> [{I,Var}|reserve(Rs, Regs, Stk)] + true -> [{reserved,I,V}|reserve_1(Rs, Regs, Stk)]; + false -> [{I,Var}|reserve_1(Rs, Regs, Stk)] end; -reserve([{I,V}|Rs], [{reserved,I,_}|Regs], Stk) -> - [{reserved,I,V}|reserve(Rs, Regs, Stk)]; -%reserve([{I,V}|Rs], [Other|Regs], Stk) -> [Other|reserve(Rs, Regs, Stk)]; -reserve([{I,V}|Rs], [], Stk) -> [{reserved,I,V}|reserve(Rs, [], Stk)]; -reserve([], Regs, _) -> Regs. - -extend_stack(Bef, Fb, Lf, Vdb) -> - Stk0 = clear_dead_stk(Bef#sr.stk, Fb, Vdb), - Saves = [V || {V,F,L} <- Vdb, - F < Fb, - L >= Lf, - not on_stack(V, Stk0)], - Stk1 = foldl(fun (V, Stk) -> put_stack(V, Stk) end, Stk0, Saves), - Bef#sr.stk ++ lists:duplicate(length(Stk1) - length(Bef#sr.stk), free). - -save_carefully(Bef, Fb, Lf, Vdb) -> - Stk = Bef#sr.stk, - %% New variables that are in use but not on stack. - New = [VFL || {V,F,L} = VFL <- Vdb, - F < Fb, - L >= Lf, - not on_stack(V, Stk)], - Saves = [V || {V,_,_} <- keysort(2, New)], - save_carefully(Saves, Bef, []). - -save_carefully([], Bef, Acc) -> {reverse(Acc),Bef}; -save_carefully([V|Vs], Bef, Acc) -> - case put_stack_carefully(V, Bef#sr.stk) of - error -> {reverse(Acc),Bef}; +reserve_1([{I,V}|Rs], [{reserved,I,_}|Regs], Stk) -> + [{reserved,I,V}|reserve_1(Rs, Regs, Stk)]; +reserve_1([{I,V}|Rs], [], Stk) -> + [{reserved,I,V}|reserve_1(Rs, [], Stk)]; +reserve_1([], Regs, _) -> Regs. + +%% extend_stack(Bef, FirstBefore, LastFrom, Vdb) -> Aft. +%% Extend the stack enough to fit all variables alive past LastFrom +%% and not already on the stack. + +extend_stack(#sr{stk=Stk0}=Bef, Fb, Lf, Vdb) -> + Stk1 = clear_dead_stk(Stk0, Fb, Vdb), + New = new_not_on_stack(Stk1, Fb, Lf, Vdb), + Stk2 = foldl(fun ({V,_,_}, Stk) -> put_stack(V, Stk) end, Stk1, New), + Stk = Stk0 ++ lists:duplicate(length(Stk2) - length(Stk0), free), + Bef#sr{stk=Stk}. + +%% save_carefully(Bef, FirstBefore, LastFrom, Vdb) -> {[SaveVar],Aft}. +%% Save variables which are used past current point and which are not +%% already on the stack, but only if the variables can be saved without +%% growing the stack frame. + +save_carefully(#sr{stk=Stk}=Bef, Fb, Lf, Vdb) -> + New0 = new_not_on_stack(Stk, Fb, Lf, Vdb), + New = keysort(2, New0), + save_carefully_1(New, Bef, []). + +save_carefully_1([{V,_,_}|Vs], #sr{reg=Regs,stk=Stk0}=Bef, Acc) -> + case put_stack_carefully(V, Stk0) of + error -> + {reverse(Acc),Bef}; Stk1 -> - SrcReg = fetch_reg(V, Bef#sr.reg), + SrcReg = fetch_reg(V, Regs), Move = {move,SrcReg,fetch_stack(V, Stk1)}, {x,_} = SrcReg, %Assertion - must be X register. - save_carefully(Vs, Bef#sr{stk=Stk1}, [Move|Acc]) - end. + save_carefully_1(Vs, Bef#sr{stk=Stk1}, [Move|Acc]) + end; +save_carefully_1([], Bef, Acc) -> + {reverse(Acc),Bef}. -x0_vars([], _Fb, _Lf, _Vdb) -> []; -x0_vars([{var,V}|_], Fb, _Lf, Vdb) -> - {V,F,_L} = VFL = vdb_find(V, Vdb), - x0_vars1([VFL], Fb, F, Vdb); -x0_vars([X0|_], Fb, Lf, Vdb) -> - x0_vars1([{X0,Lf,Lf}], Fb, Lf, Vdb). - -x0_vars1(X0, Fb, Xf, Vdb) -> - Vs0 = [VFL || {_V,F,L}=VFL <- Vdb, - F >= Fb, - L < Xf], - Vs1 = keysort(3, Vs0), - keysort(2, X0++Vs1). - -allocate_x0([], _, Bef) -> {[],Bef#sr{res=[]}}; -allocate_x0([{_,_,L}|Vs], I, Bef) when L =< I -> - allocate_x0(Vs, I, Bef); -allocate_x0([{V,_F,_L}=VFL|Vs], _, Bef) -> - {[VFL|Vs],Bef#sr{res=reserve_x0(V, Bef#sr.res)}}. - -reserve_x0(V, [_|Res]) -> [{0,V}|Res]; -reserve_x0(V, []) -> [{0,V}]. +%% top_level_block([Instruction], Bef, MaxRegs, St) -> [Instruction]. +%% For the top-level block, allocate a stack frame a necessary, +%% adjust Y register numbering and instructions that return +%% from the function. top_level_block(Keis, #sr{stk=[]}, _MaxRegs, #cg{need_frame=false}) -> Keis; @@ -640,23 +1067,27 @@ turn_yreg(Other, _MaxY) -> %% wrong. These are different as in the second case there is no need %% to try the next type, it will always fail. -select_cg(#l{ke={type_clause,cons,[S]}}, {var,V}, Tf, Vf, Bef, St) -> +select_cg(#k_type_clause{type=Type,values=Vs}, Var, Tf, Vf, Bef, St) -> + #k_var{name=V} = Var, + select_cg(Type, Vs, V, Tf, Vf, Bef, St). + +select_cg(k_cons, [S], V, Tf, Vf, Bef, St) -> select_cons(S, V, Tf, Vf, Bef, St); -select_cg(#l{ke={type_clause,nil,[S]}}, {var,V}, Tf, Vf, Bef, St) -> +select_cg(k_nil, [S], V, Tf, Vf, Bef, St) -> select_nil(S, V, Tf, Vf, Bef, St); -select_cg(#l{ke={type_clause,binary,[S]}}, {var,V}, Tf, Vf, Bef, St) -> +select_cg(k_binary, [S], V, Tf, Vf, Bef, St) -> select_binary(S, V, Tf, Vf, Bef, St); -select_cg(#l{ke={type_clause,bin_seg,S}}, {var,V}, Tf, _Vf, Bef, St) -> +select_cg(k_bin_seg, S, V, Tf, _Vf, Bef, St) -> select_bin_segs(S, V, Tf, Bef, St); -select_cg(#l{ke={type_clause,bin_int,S}}, {var,V}, Tf, _Vf, Bef, St) -> +select_cg(k_bin_int, S, V, Tf, _Vf, Bef, St) -> select_bin_segs(S, V, Tf, Bef, St); -select_cg(#l{ke={type_clause,bin_end,[S]}}, {var,V}, Tf, _Vf, Bef, St) -> +select_cg(k_bin_end, [S], V, Tf, _Vf, Bef, St) -> select_bin_end(S, V, Tf, Bef, St); -select_cg(#l{ke={type_clause,map,S}}, {var,V}, Tf, Vf, Bef, St) -> +select_cg(k_map, S, V, Tf, Vf, Bef, St) -> select_map(S, V, Tf, Vf, Bef, St); -select_cg(#l{ke={type_clause,literal,S}}, {var,V}, Tf, Vf, Bef, St) -> +select_cg(k_literal, S, V, Tf, Vf, Bef, St) -> select_literal(S, V, Tf, Vf, Bef, St); -select_cg(#l{ke={type_clause,Type,Scs}}, {var,V}, Tf, Vf, Bef, St0) -> +select_cg(Type, Scs, V, Tf, Vf, Bef, St0) -> {Vis,{Aft,St1}} = mapfoldl(fun (S, {Int,Sta}) -> {Val,Is,Inta,Stb} = select_val(S, V, Vf, Bef, Sta), @@ -666,22 +1097,29 @@ select_cg(#l{ke={type_clause,Type,Scs}}, {var,V}, Tf, Vf, Bef, St0) -> {Vls,Sis,St2} = select_labels(OptVls, St1, [], []), {select_val_cg(Type, fetch_var(V, Bef), Vls, Tf, Vf, Sis), Aft, St2}. -select_val_cg(tuple, R, [Arity,{f,Lbl}], Tf, Vf, [{label,Lbl}|Sis]) -> +select_val_cg(k_tuple, R, [Arity,{f,Lbl}], Tf, Vf, [{label,Lbl}|Sis]) -> [{test,is_tuple,{f,Tf},[R]},{test,test_arity,{f,Vf},[R,Arity]}|Sis]; -select_val_cg(tuple, R, Vls, Tf, Vf, Sis) -> +select_val_cg(k_tuple, R, Vls, Tf, Vf, Sis) -> [{test,is_tuple,{f,Tf},[R]},{select_tuple_arity,R,{f,Vf},{list,Vls}}|Sis]; select_val_cg(Type, R, [Val, {f,Lbl}], Fail, Fail, [{label,Lbl}|Sis]) -> - [{test,is_eq_exact,{f,Fail},[R,{Type,Val}]}|Sis]; + [{test,is_eq_exact,{f,Fail},[R,{type(Type),Val}]}|Sis]; select_val_cg(Type, R, [Val, {f,Lbl}], Tf, Vf, [{label,Lbl}|Sis]) -> [{test,select_type_test(Type),{f,Tf},[R]}, - {test,is_eq_exact,{f,Vf},[R,{Type,Val}]}|Sis]; + {test,is_eq_exact,{f,Vf},[R,{type(Type),Val}]}|Sis]; select_val_cg(Type, R, Vls0, Tf, Vf, Sis) -> - Vls1 = [case Value of {f,_Lbl} -> Value; _ -> {Type,Value} end || Value <- Vls0], + Vls1 = [case Value of + {f,_Lbl} -> Value; + _ -> {type(Type),Value} + end || Value <- Vls0], [{test,select_type_test(Type),{f,Tf},[R]}, {select_val,R,{f,Vf},{list,Vls1}}|Sis]. - -select_type_test(integer) -> is_integer; -select_type_test(atom) -> is_atom; -select_type_test(float) -> is_float. + +type(k_atom) -> atom; +type(k_float) -> float; +type(k_int) -> integer. + +select_type_test(k_int) -> is_integer; +select_type_test(k_atom) -> is_atom; +select_type_test(k_float) -> is_float. combine([{Is,Vs1}, {Is,Vs2}|Vis]) -> combine([{Is,Vs1 ++ Vs2}|Vis]); combine([V|Vis]) -> [V|combine(Vis)]; @@ -706,36 +1144,40 @@ select_literal(S, V, Tf, Vf, Bef, St) -> end, match_fmf(F, Tf, St, S). -select_cons(#l{ke={val_clause,{cons,Es},B},i=I,vdb=Vdb}, V, Tf, Vf, Bef, St0) -> +select_cons(#k_val_clause{val=#k_cons{hd=Hd,tl=Tl},body=B,anno=#l{i=I,vdb=Vdb}}, + V, Tf, Vf, Bef, St0) -> + Es = [Hd,Tl], {Eis,Int,St1} = select_extract_cons(V, Es, I, Vdb, Bef, St0), {Bis,Aft,St2} = match_cg(B, Vf, Int, St1), {[{test,is_nonempty_list,{f,Tf},[fetch_var(V, Bef)]}] ++ Eis ++ Bis,Aft,St2}. -select_nil(#l{ke={val_clause,nil,B}}, V, Tf, Vf, Bef, St0) -> +select_nil(#k_val_clause{val=#k_nil{},body=B}, V, Tf, Vf, Bef, St0) -> {Bis,Aft,St1} = match_cg(B, Vf, Bef, St0), {[{test,is_nil,{f,Tf},[fetch_var(V, Bef)]}] ++ Bis,Aft,St1}. -select_binary(#l{ke={val_clause,{binary,{var,V}},B},i=I,vdb=Vdb}, - V, Tf, Vf, Bef, St0) -> +select_binary(#k_val_clause{val=#k_binary{segs=#k_var{name=V}},body=B, + anno=#l{i=I,vdb=Vdb}}, V, Tf, Vf, Bef, St0) -> + #cg{ctx=OldCtx} = St0, Int0 = clear_dead(Bef#sr{reg=Bef#sr.reg}, I, Vdb), - {Bis0,Aft,St1} = match_cg(B, Vf, Int0, St0), + {Bis0,Aft,St1} = match_cg(B, Vf, Int0, St0#cg{ctx=V}), CtxReg = fetch_var(V, Int0), Live = max_reg(Bef#sr.reg), Bis1 = [{test,bs_start_match2,{f,Tf},Live,[CtxReg,V],CtxReg}, {bs_save2,CtxReg,{V,V}}|Bis0], Bis = finish_select_binary(Bis1), - {Bis,Aft,St1}; -select_binary(#l{ke={val_clause,{binary,{var,Ivar}},B},i=I,vdb=Vdb}, - V, Tf, Vf, Bef, St0) -> + {Bis,Aft,St1#cg{ctx=OldCtx}}; +select_binary(#k_val_clause{val=#k_binary{segs=#k_var{name=Ivar}},body=B, + anno=#l{i=I,vdb=Vdb}}, V, Tf, Vf, Bef, St0) -> + #cg{ctx=OldCtx} = St0, Regs = put_reg(Ivar, Bef#sr.reg), Int0 = clear_dead(Bef#sr{reg=Regs}, I, Vdb), - {Bis0,Aft,St1} = match_cg(B, Vf, Int0, St0), + {Bis0,Aft,St1} = match_cg(B, Vf, Int0, St0#cg{ctx=Ivar}), CtxReg = fetch_var(Ivar, Int0), Live = max_reg(Bef#sr.reg), Bis1 = [{test,bs_start_match2,{f,Tf},Live,[fetch_var(V, Bef),Ivar],CtxReg}, {bs_save2,CtxReg,{Ivar,Ivar}}|Bis0], Bis = finish_select_binary(Bis1), - {Bis,Aft,St1}. + {Bis,Aft,St1#cg{ctx=OldCtx}}. finish_select_binary([{bs_save2,R,Point}=I,{bs_restore2,R,Point}|Is]) -> [I|finish_select_binary(Is)]; @@ -757,9 +1199,16 @@ select_bin_segs(Scs, Ivar, Tf, Bef, St) -> select_bin_seg(S, Ivar, Fail, Bef, Sta) end, Tf, St, Scs). -select_bin_seg(#l{ke={val_clause,{bin_seg,Ctx,Size,U,T,Fs0,Es},B},i=I,vdb=Vdb,a=A}, - Ivar, Fail, Bef, St0) -> +select_bin_seg(#k_val_clause{val=#k_bin_seg{size=Size,unit=U,type=T, + seg=Seg,flags=Fs0,next=Next}, + body=B, + anno=#l{i=I,vdb=Vdb,a=A}}, Ivar, Fail, Bef, St0) -> + Ctx = St0#cg.ctx, Fs = [{anno,A}|Fs0], + Es = case Next of + [] -> [Seg]; + _ -> [Seg,Next] + end, {Mis,Int,St1} = select_extract_bin(Es, Size, U, T, Fs, Fail, I, Vdb, Bef, Ctx, B, St0), {Bis,Aft,St2} = match_cg(B, Fail, Int, St1), @@ -772,9 +1221,12 @@ select_bin_seg(#l{ke={val_clause,{bin_seg,Ctx,Size,U,T,Fs0,Es},B},i=I,vdb=Vdb,a= [{bs_restore2,CtxReg,{Ctx,Ivar}}|Mis++Bis] end, {Is,Aft,St2}; -select_bin_seg(#l{ke={val_clause,{bin_int,Ctx,Sz,U,Fs,Val,Es},B},i=I,vdb=Vdb}, - Ivar, Fail, Bef, St0) -> - {Mis,Int,St1} = select_extract_int(Es, Val, Sz, U, Fs, Fail, +select_bin_seg(#k_val_clause{val=#k_bin_int{size=Sz,unit=U,flags=Fs, + val=Val,next=Next}, + body=B, + anno=#l{i=I,vdb=Vdb}}, Ivar, Fail, Bef, St0) -> + Ctx = St0#cg.ctx, + {Mis,Int,St1} = select_extract_int(Next, Val, Sz, U, Fs, Fail, I, Vdb, Bef, Ctx, St0), {Bis,Aft,St2} = match_cg(B, Fail, Int, St1), CtxReg = fetch_var(Ctx, Bef), @@ -795,7 +1247,7 @@ select_bin_seg(#l{ke={val_clause,{bin_int,Ctx,Sz,U,Fs,Val,Es},B},i=I,vdb=Vdb}, end, {[{bs_restore2,CtxReg,{Ctx,Ivar}}|Is],Aft,St2}. -select_extract_int([{var,Tl}], Val, {integer,Sz}, U, Fs, Vf, +select_extract_int(#k_var{name=Tl}, Val, #k_int{val=Sz}, U, Fs, Vf, I, Vdb, Bef, Ctx, St) -> Bits = U*Sz, Bin = case member(big, Fs) of @@ -816,7 +1268,7 @@ select_extract_int([{var,Tl}], Val, {integer,Sz}, U, Fs, Vf, end, {Is,clear_dead(Bef, I, Vdb),St}. -select_extract_bin([{var,Hd},{var,Tl}], Size0, Unit, Type, Flags, Vf, +select_extract_bin([#k_var{name=Hd},#k_var{name=Tl}], Size0, Unit, Type, Flags, Vf, I, Vdb, Bef, Ctx, _Body, St) -> SizeReg = get_bin_size_reg(Size0, Bef), {Es,Aft} = @@ -839,11 +1291,11 @@ select_extract_bin([{var,Hd},{var,Tl}], Size0, Unit, Type, Flags, Vf, {bs_save2,CtxReg,{Ctx,Tl}}],Int1} end, {Es,clear_dead(Aft, I, Vdb),St}; -select_extract_bin([{var,Hd}], Size, Unit, binary, Flags, Vf, +select_extract_bin([#k_var{name=Hd}], Size, Unit, binary, Flags, Vf, I, Vdb, Bef, Ctx, Body, St) -> %% Match the last segment of a binary. We KNOW that the size %% must be 'all'. - Size = {atom,all}, %Assertion. + #k_atom{val=all} = Size, %Assertion. {Es,Aft} = case vdb_find(Hd, Vdb) of {_,_,Lhd} when Lhd =< I -> @@ -868,7 +1320,7 @@ select_extract_bin([{var,Hd}], Size, Unit, binary, Flags, Vf, Name = bs_get_binary2, Live = max_reg(Bef#sr.reg), {[{test,Name,{f,Vf},Live, - [CtxReg,Size,Unit,{field_flags,Flags}],Rhd}], + [CtxReg,atomic(Size),Unit,{field_flags,Flags}],Rhd}], Int1}; true -> %% Since the matching context will not be used again, @@ -883,43 +1335,42 @@ select_extract_bin([{var,Hd}], Size, Unit, binary, Flags, Vf, Name = bs_get_binary2, Live = max_reg(Int1#sr.reg), {[{test,Name,{f,Vf},Live, - [CtxReg,Size,Unit,{field_flags,Flags}],CtxReg}], + [CtxReg,atomic(Size),Unit,{field_flags,Flags}],CtxReg}], Int1} end end, {Es,clear_dead(Aft, I, Vdb),St}. %% is_context_unused(Ke) -> true | false -%% Simple heurististic to determine whether the code that follows will -%% use the current matching context again. (The information of liveness -%% calculcated by v3_life is too conservative to be useful for this purpose.) -%% 'true' means that the code that follows will definitely not use the context -%% again (because it is a block, not guard or matching code); 'false' that we -%% are not sure (there could be more matching). - -is_context_unused(#l{ke=Ke}) -> - is_context_unused(Ke); -is_context_unused({alt,_First,Then}) -> - %% {alt,First,Then} can be used for different purposes. If the Then part +%% Simple heurististic to determine whether the code that follows +%% will use the current matching context again. (The liveness +%% information is too conservative to be useful for this purpose.) +%% 'true' means that the code that follows will definitely not use +%% the context again (because it is a block, not guard or matching +%% code); 'false' that we are not sure (there could be more +%% matching). + +is_context_unused(#k_alt{then=Then}) -> + %% #k_alt{} can be used for different purposes. If the Then part %% is a block, it means that matching has finished and is used for a guard %% to choose between the matched clauses. is_context_unused(Then); -is_context_unused({block,_}) -> +is_context_unused(#cg_block{}) -> true; is_context_unused(_) -> false. -select_bin_end(#l{ke={val_clause,{bin_end,Ctx},B}}, - Ivar, Tf, Bef, St0) -> +select_bin_end(#k_val_clause{val=#k_bin_end{},body=B}, Ivar, Tf, Bef, St0) -> + Ctx = St0#cg.ctx, {Bis,Aft,St2} = match_cg(B, Tf, Bef, St0), CtxReg = fetch_var(Ctx, Bef), {[{bs_restore2,CtxReg,{Ctx,Ivar}}, {test,bs_test_tail2,{f,Tf},[CtxReg,0]}|Bis],Aft,St2}. -get_bin_size_reg({var,V}, Bef) -> +get_bin_size_reg(#k_var{name=V}, Bef) -> fetch_var(V, Bef); get_bin_size_reg(Literal, _Bef) -> - Literal. + atomic(Literal). build_bs_instr(Type, Vf, CtxReg, Live, SizeReg, Unit, Flags, Rhd) -> {Format,Name} = case Type of @@ -953,11 +1404,18 @@ build_skip_instr(Type, Vf, CtxReg, Live, SizeReg, Unit, Flags) -> {test,Name,{f,Vf},[CtxReg,Live,{field_flags,Flags}]} end. -select_val(#l{ke={val_clause,{tuple,Es},B},i=I,vdb=Vdb}, V, Vf, Bef, St0) -> +select_val(#k_val_clause{val=#k_tuple{es=Es},body=B,anno=#l{i=I,vdb=Vdb}}, + V, Vf, Bef, St0) -> {Eis,Int,St1} = select_extract_tuple(V, Es, I, Vdb, Bef, St0), {Bis,Aft,St2} = match_cg(B, Vf, Int, St1), {length(Es),Eis ++ Bis,Aft,St2}; -select_val(#l{ke={val_clause,{_,Val},B}}, _V, Vf, Bef, St0) -> +select_val(#k_val_clause{val=Val0,body=B}, _V, Vf, Bef, St0) -> + Val = case Val0 of + #k_atom{val=Lit} -> Lit; + #k_float{val=Lit} -> Lit; + #k_int{val=Lit} -> Lit; + #k_literal{val=Lit} -> Lit + end, {Bis,Aft,St1} = match_cg(B, Vf, Bef, St0), {Val,Bis,Aft,St1}. @@ -966,7 +1424,7 @@ select_val(#l{ke={val_clause,{_,Val},B}}, _V, Vf, Bef, St0) -> %% Extract tuple elements, but only if they do not immediately die. select_extract_tuple(Src, Vs, I, Vdb, Bef, St) -> - F = fun ({var,V}, {Int0,Elem}) -> + F = fun (#k_var{name=V}, {Int0,Elem}) -> case vdb_find(V, Vdb) of {V,_,L} when L =< I -> {[], {Int0,Elem+1}}; _Other -> @@ -983,9 +1441,10 @@ select_extract_tuple(Src, Vs, I, Vdb, Bef, St) -> select_map(Scs, V, Tf, Vf, Bef, St0) -> Reg = fetch_var(V, Bef), {Is,Aft,St1} = - match_fmf(fun(#l{ke={val_clause,{map,exact,_,Es},B},i=I,vdb=Vdb}, Fail, St1) -> - select_map_val(V, Es, B, Fail, I, Vdb, Bef, St1) - end, Vf, St0, Scs), + match_fmf(fun(#k_val_clause{val=#k_map{op=exact,es=Es}, + body=B,anno=#l{i=I,vdb=Vdb}}, Fail, St1) -> + select_map_val(V, Es, B, Fail, I, Vdb, Bef, St1) + end, Vf, St0, Scs), {[{test,is_map,{f,Tf},[Reg]}|Is],Aft,St1}. select_map_val(V, Es, B, Fail, I, Vdb, Bef, St0) -> @@ -1002,29 +1461,32 @@ select_extract_map(Src, Vs, Fail, I, Vdb, Bef, St) -> %% Assume keys are term-sorted Rsrc = fetch_var(Src, Bef), - {{HasKs,GetVs,HasVarKs,GetVarVs},Aft} = lists:foldr(fun - ({map_pair,{var,K},{var,V}},{{HasKsi,GetVsi,HasVarVsi,GetVarVsi},Int0}) -> - case vdb_find(V, Vdb) of - {V,_,L} when L =< I -> - RK = fetch_var(K,Int0), - {{HasKsi,GetVsi,[RK|HasVarVsi],GetVarVsi},Int0}; - _Other -> - Reg1 = put_reg(V, Int0#sr.reg), - Int1 = Int0#sr{reg=Reg1}, - RK = fetch_var(K,Int0), - RV = fetch_reg(V,Reg1), - {{HasKsi,GetVsi,HasVarVsi,[[RK,RV]|GetVarVsi]},Int1} - end; - ({map_pair,Key,{var,V}},{{HasKsi,GetVsi,HasVarVsi,GetVarVsi},Int0}) -> - case vdb_find(V, Vdb) of - {V,_,L} when L =< I -> - {{[Key|HasKsi],GetVsi,HasVarVsi,GetVarVsi},Int0}; - _Other -> - Reg1 = put_reg(V, Int0#sr.reg), - Int1 = Int0#sr{reg=Reg1}, - {{HasKsi,[Key,fetch_reg(V, Reg1)|GetVsi],HasVarVsi,GetVarVsi},Int1} - end - end, {{[],[],[],[]},Bef}, Vs), + {{HasKs,GetVs,HasVarKs,GetVarVs},Aft} = + foldr(fun(#k_map_pair{key=#k_var{name=K},val=#k_var{name=V}}, + {{HasKsi,GetVsi,HasVarVsi,GetVarVsi},Int0}) -> + case vdb_find(V, Vdb) of + {V,_,L} when L =< I -> + RK = fetch_var(K,Int0), + {{HasKsi,GetVsi,[RK|HasVarVsi],GetVarVsi},Int0}; + _Other -> + Reg1 = put_reg(V, Int0#sr.reg), + Int1 = Int0#sr{reg=Reg1}, + RK = fetch_var(K,Int0), + RV = fetch_reg(V,Reg1), + {{HasKsi,GetVsi,HasVarVsi,[[RK,RV]|GetVarVsi]},Int1} + end; + (#k_map_pair{key=Key,val=#k_var{name=V}}, + {{HasKsi,GetVsi,HasVarVsi,GetVarVsi},Int0}) -> + case vdb_find(V, Vdb) of + {V,_,L} when L =< I -> + {{[atomic(Key)|HasKsi],GetVsi,HasVarVsi,GetVarVsi},Int0}; + _Other -> + Reg1 = put_reg(V, Int0#sr.reg), + Int1 = Int0#sr{reg=Reg1}, + {{HasKsi,[atomic(Key),fetch_reg(V, Reg1)|GetVsi], + HasVarVsi,GetVarVsi},Int1} + end + end, {{[],[],[],[]},Bef}, Vs), Code = [{test,has_map_fields,{f,Fail},Rsrc,{list,HasKs}} || HasKs =/= []] ++ [{test,has_map_fields,{f,Fail},Rsrc,{list,[K]}} || K <- HasVarKs] ++ @@ -1033,30 +1495,36 @@ select_extract_map(Src, Vs, Fail, I, Vdb, Bef, St) -> {Code, Aft, St}. -select_extract_cons(Src, [{var,Hd}, {var,Tl}], I, Vdb, Bef, St) -> - {Es,Aft} = case {vdb_find(Hd, Vdb), vdb_find(Tl, Vdb)} of - {{_,_,Lhd}, {_,_,Ltl}} when Lhd =< I, Ltl =< I -> - %% Both head and tail are dead. No need to generate - %% any instruction. - {[], Bef}; - _ -> - %% At least one of head and tail will be used, - %% but we must always fetch both. We will call - %% clear_dead/2 to allow reuse of the register - %% in case only of them is used. - - Reg0 = put_reg(Tl, put_reg(Hd, Bef#sr.reg)), - Int0 = Bef#sr{reg=Reg0}, - Rsrc = fetch_var(Src, Int0), - Rhd = fetch_reg(Hd, Reg0), - Rtl = fetch_reg(Tl, Reg0), - Int1 = clear_dead(Int0, I, Vdb), - {[{get_list,Rsrc,Rhd,Rtl}], Int1} - end, - {Es,Aft,St}. - +select_extract_cons(Src, [#k_var{name=Hd},#k_var{name=Tl}], I, Vdb, Bef, St) -> + Rsrc = fetch_var(Src, Bef), + Int = clear_dead(Bef, I, Vdb), + {{_,_,Lhd},{_,_,Ltl}} = {vdb_find(Hd, Vdb),vdb_find(Tl, Vdb)}, + case {Lhd =< I, Ltl =< I} of + {true,true} -> + %% Both dead. + {[],Bef,St}; + {true,false} -> + %% Head dead. + Reg0 = put_reg(Tl, Bef#sr.reg), + Aft = Int#sr{reg=Reg0}, + Rtl = fetch_reg(Tl, Reg0), + {[{get_tl,Rsrc,Rtl}],Aft,St}; + {false,true} -> + %% Tail dead. + Reg0 = put_reg(Hd, Bef#sr.reg), + Aft = Int#sr{reg=Reg0}, + Rhd = fetch_reg(Hd, Reg0), + {[{get_hd,Rsrc,Rhd}],Aft,St}; + {false,false} -> + %% Both used. + Reg0 = put_reg(Tl, put_reg(Hd, Bef#sr.reg)), + Aft = Bef#sr{reg=Reg0}, + Rhd = fetch_reg(Hd, Reg0), + Rtl = fetch_reg(Tl, Reg0), + {[{get_hd,Rsrc,Rhd},{get_tl,Rsrc,Rtl}],Aft,St} + end. -guard_clause_cg(#l{ke={guard_clause,G,B},vdb=Vdb}, Fail, Bef, St0) -> +guard_clause_cg(#k_guard_clause{anno=#l{vdb=Vdb},guard=G,body=B}, Fail, Bef, St0) -> {Gis,Int,St1} = guard_cg(G, Fail, Vdb, Bef, St0), {Bis,Aft,St} = match_cg(B, Fail, Int, St1), {Gis ++ Bis,Aft,St}. @@ -1069,11 +1537,11 @@ guard_clause_cg(#l{ke={guard_clause,G,B},vdb=Vdb}, Fail, Bef, St0) -> %% the correct exit point. Primops and tests all go to the next %% instruction on success or jump to a failure label. -guard_cg(#l{ke={protected,Ts,Rs},i=I,vdb=Pdb}, Fail, _Vdb, Bef, St) -> - protected_cg(Ts, Rs, Fail, I, Pdb, Bef, St); -guard_cg(#l{ke={block,Ts},i=I,vdb=Bdb}, Fail, _Vdb, Bef, St) -> - guard_cg_list(Ts, Fail, I, Bdb, Bef, St); -guard_cg(#l{ke={test,Test,As,Inverted},i=I,vdb=_Tdb}, Fail, Vdb, Bef, St0) -> +guard_cg(#k_protected{arg=Ts,ret=Rs,anno=#l{vdb=Pdb}}, Fail, _Vdb, Bef, St) -> + protected_cg(Ts, Rs, Fail, Pdb, Bef, St); +guard_cg(#k_test{anno=#l{i=I},op=Test0,args=As,inverted=Inverted}, + Fail, Vdb, Bef, St0) -> + #k_remote{mod=#k_atom{val=erlang},name=#k_atom{val=Test}} = Test0, case Inverted of false -> test_cg(Test, As, Fail, I, Vdb, Bef, St0); @@ -1088,6 +1556,18 @@ guard_cg(G, _Fail, Vdb, Bef, St) -> %%ok = io:fwrite("cg ~w: ~p~n", [?LINE,{Aft}]), {Gis,Aft,St1}. +%% guard_cg_list([Kexpr], Fail, I, Vdb, StackReg, St) -> +%% {[Ainstr],StackReg,St}. + +guard_cg_list(Kes, Fail, Vdb, Bef, St0) -> + {Keis,{Aft,St1}} = + flatmapfoldl(fun (Ke, {Inta,Sta}) -> + {Keis,Intb,Stb} = + guard_cg(Ke, Fail, Vdb, Inta, Sta), + {Keis,{Intb,Stb}} + end, {Bef,St0}, need_heap(Kes)), + {Keis,Aft,St1}. + %% protected_cg([Kexpr], [Ret], Fail, I, Vdb, Bef, St) -> {[Ainstr],Aft,St}. %% Do a protected. Protecteds without return values are just done %% for effect, the return value is not checked, success passes on to @@ -1095,19 +1575,18 @@ guard_cg(G, _Fail, Vdb, Bef, St) -> %% return values then these must be set to 'false' on failure, %% control always passes to the next instruction. -protected_cg(Ts, [], Fail, I, Vdb, Bef, St0) -> +protected_cg(Ts, [], Fail, Vdb, Bef, St0) -> %% Protect these calls, revert when done. - {Tis,Aft,St1} = guard_cg_list(Ts, Fail, I, Vdb, Bef, - St0#cg{bfail=Fail}), + {Tis,Aft,St1} = guard_cg_list(Ts, Fail, Vdb, Bef, St0#cg{bfail=Fail}), {Tis,Aft,St1#cg{bfail=St0#cg.bfail}}; -protected_cg(Ts, Rs, _Fail, I, Vdb, Bef, St0) -> +protected_cg(Ts, Rs, _Fail, Vdb, Bef, St0) -> {Pfail,St1} = new_label(St0), {Psucc,St2} = new_label(St1), - {Tis,Aft,St3} = guard_cg_list(Ts, Pfail, I, Vdb, Bef, + {Tis,Aft,St3} = guard_cg_list(Ts, Pfail, Vdb, Bef, St2#cg{bfail=Pfail}), %%ok = io:fwrite("cg ~w: ~p~n", [?LINE,{Rs,I,Vdb,Aft}]), %% Set return values to false. - Mis = [{move,{atom,false},fetch_var(V,Aft)}||{var,V} <- Rs], + Mis = [{move,{atom,false},fetch_var(V,Aft)}||#k_var{name=V} <- Rs], {Tis ++ [{jump,{f,Psucc}}, {label,Pfail}] ++ Mis ++ [{label,Psucc}], Aft,St3#cg{bfail=St0#cg.bfail}}. @@ -1132,7 +1611,7 @@ test_cg(is_map, [A], Fail, I, Vdb, Bef, St) -> Arg = cg_reg_arg_prefer_y(A, Bef), Aft = clear_dead(Bef, I, Vdb), {[{test,is_map,{f,Fail},[Arg]}],Aft,St}; -test_cg(is_boolean, [{atom,Val}], Fail, I, Vdb, Bef, St) -> +test_cg(is_boolean, [#k_atom{val=Val}], Fail, I, Vdb, Bef, St) -> Aft = clear_dead(Bef, I, Vdb), Is = case is_boolean(Val) of true -> []; @@ -1144,18 +1623,6 @@ test_cg(Test, As, Fail, I, Vdb, Bef, St) -> Aft = clear_dead(Bef, I, Vdb), {[beam_utils:bif_to_test(Test, Args, {f,Fail})],Aft,St}. -%% guard_cg_list([Kexpr], Fail, I, Vdb, StackReg, St) -> -%% {[Ainstr],StackReg,St}. - -guard_cg_list(Kes, Fail, I, Vdb, Bef, St0) -> - {Keis,{Aft,St1}} = - flatmapfoldl(fun (Ke, {Inta,Sta}) -> - {Keis,Intb,Stb} = - guard_cg(Ke, Fail, Vdb, Inta, Sta), - {Keis,{Intb,Stb}} - end, {Bef,St0}, need_heap(Kes, I)), - {Keis,Aft,St1}. - %% match_fmf(Fun, LastFail, State, [Clause]) -> {Is,Aft,State}. %% This is a special flatmapfoldl for match code gen where we %% generate a "failure" label for each clause. The last clause uses @@ -1178,7 +1645,7 @@ match_fmf(F, LastFail, St0, [H|T]) -> %% frame size. Finally the actual call is made. Call then needs the %% return values filled in. -call_cg({var,_V} = Var, As, Rs, Le, Vdb, Bef, St0) -> +call_cg(#k_var{}=Var, As, Rs, Le, Vdb, Bef, St0) -> {Sis,Int} = cg_setup_call(As++[Var], Bef, Le#l.i, Vdb), %% Put return values in registers. Reg = load_vars(Rs, clear_regs(Int#sr.reg)), @@ -1187,9 +1654,8 @@ call_cg({var,_V} = Var, As, Rs, Le, Vdb, Bef, St0) -> {Frees,Aft} = free_dead(clear_dead(Int#sr{reg=Reg}, Le#l.i, Vdb)), {Sis ++ Frees ++ [line(Le),{call_fun,Arity}],Aft, need_stack_frame(St0)}; -call_cg({remote,Mod,Name}, As, Rs, Le, Vdb, Bef, St0) - when element(1, Mod) =:= var; - element(1, Name) =:= var -> +call_cg(#k_remote{mod=Mod,name=Name}, As, Rs, Le, Vdb, Bef, St0) + when is_record(Mod, k_var); is_record(Name, k_var) -> {Sis,Int} = cg_setup_call(As++[Mod,Name], Bef, Le#l.i, Vdb), %% Put return values in registers. Reg = load_vars(Rs, clear_regs(Int#sr.reg)), @@ -1207,8 +1673,9 @@ call_cg(Func, As, Rs, Le, Vdb, Bef, St0) -> %% %% move {atom,ok} DestReg %% jump FailureLabel - {remote,{atom,erlang},{atom,error}} = Func, %Assertion. - [{var,DestVar}] = Rs, + #k_remote{mod=#k_atom{val=erlang}, + name=#k_atom{val=error}} = Func, %Assertion. + [#k_var{name=DestVar}] = Rs, Int0 = clear_dead(Bef, Le#l.i, Vdb), Reg = put_reg(DestVar, Int0#sr.reg), Int = Int0#sr{reg=Reg}, @@ -1227,11 +1694,11 @@ call_cg(Func, As, Rs, Le, Vdb, Bef, St0) -> {Sis ++ Frees ++ [line(Le)|Call],Aft,St1} end. -build_call({remote,{atom,erlang},{atom,'!'}}, 2, St0) -> +build_call(#k_remote{mod=#k_atom{val=erlang},name=#k_atom{val='!'}}, 2, St0) -> {[send],need_stack_frame(St0)}; -build_call({remote,{atom,Mod},{atom,Name}}, Arity, St0) -> +build_call(#k_remote{mod=#k_atom{val=Mod},name=#k_atom{val=Name}}, Arity, St0) -> {[{call_ext,Arity,{extfunc,Mod,Name,Arity}}],need_stack_frame(St0)}; -build_call(Name, Arity, St0) when is_atom(Name) -> +build_call(#k_local{name=Name}, Arity, St0) when is_atom(Name) -> {Lbl,St1} = local_func_label(Name, Arity, need_stack_frame(St0)), {[{call,Arity,{f,Lbl}}],St1}. @@ -1247,16 +1714,15 @@ free_dead([Any|Stk], Y, Instr, StkAcc) -> free_dead(Stk, Y+1, Instr, [Any|StkAcc]); free_dead([], _, Instr, StkAcc) -> {Instr,reverse(StkAcc)}. -enter_cg({var,_V} = Var, As, Le, Vdb, Bef, St0) -> +enter_cg(#k_var{} = Var, As, Le, Vdb, Bef, St0) -> {Sis,Int} = cg_setup_call(As++[Var], Bef, Le#l.i, Vdb), %% Build complete code and final stack/register state. Arity = length(As), {Sis ++ [line(Le),{call_fun,Arity},return], clear_dead(Int#sr{reg=clear_regs(Int#sr.reg)}, Le#l.i, Vdb), need_stack_frame(St0)}; -enter_cg({remote,Mod,Name}, As, Le, Vdb, Bef, St0) - when element(1, Mod) =:= var; - element(1, Name) =:= var -> +enter_cg(#k_remote{mod=Mod,name=Name}, As, Le, Vdb, Bef, St0) + when is_record(Mod, k_var); is_record(Name, k_var) -> {Sis,Int} = cg_setup_call(As++[Mod,Name], Bef, Le#l.i, Vdb), %% Build complete code and final stack/register state. Arity = length(As), @@ -1274,19 +1740,19 @@ enter_cg(Func, As, Le, Vdb, Bef, St0) -> clear_dead(Int#sr{reg=clear_regs(Int#sr.reg)}, Le#l.i, Vdb), St1}. -build_enter({remote,{atom,erlang},{atom,'!'}}, 2, St0) -> +build_enter(#k_remote{mod=#k_atom{val=erlang},name=#k_atom{val='!'}}, 2, St0) -> {[send,return],need_stack_frame(St0)}; -build_enter({remote,{atom,Mod},{atom,Name}}, Arity, St0) -> +build_enter(#k_remote{mod=#k_atom{val=Mod},name=#k_atom{val=Name}}, Arity, St0) -> St1 = case trap_bif(Mod, Name, Arity) of true -> need_stack_frame(St0); false -> St0 end, {[{call_ext_only,Arity,{extfunc,Mod,Name,Arity}}],St1}; -build_enter(Name, Arity, St0) when is_atom(Name) -> +build_enter(#k_local{name=Name}, Arity, St0) when is_atom(Name) -> {Lbl,St1} = local_func_label(Name, Arity, St0), {[{call_only,Arity,{f,Lbl}}],St1}. -enter_line({remote,{atom,Mod},{atom,Name}}, Arity, Le) -> +enter_line(#k_remote{mod=#k_atom{val=Mod},name=#k_atom{val=Name}}, Arity, Le) -> case erl_bifs:is_safe(Mod, Name, Arity) of false -> %% Tail-recursive call, possibly to a BIF. @@ -1334,17 +1800,28 @@ trap_bif(erlang, group_leader, 2) -> true; trap_bif(erlang, exit, 2) -> true; trap_bif(_, _, _) -> false. +%% bif_cg(#k_bif{}, Le, Vdb, StackReg, State) -> +%% {[Ainstr],StackReg,State}. +%% Generate code a BIF. + +bif_cg(#k_bif{op=#k_internal{name=Name},args=As,ret=Rs}, Le, Vdb, Bef, St) -> + internal_cg(Name, As, Rs, Le, Vdb, Bef, St); +bif_cg(#k_bif{op=#k_remote{mod=#k_atom{val=erlang},name=#k_atom{val=Name}}, + args=As,ret=Rs}, Le, Vdb, Bef, St) -> + Ar = length(As), + case is_gc_bif(Name, Ar) of + false -> + bif_cg(Name, As, Rs, Le, Vdb, Bef, St); + true -> + gc_bif_cg(Name, As, Rs, Le, Vdb, Bef, St) + end. + %% internal_cg(Bif, [Arg], [Ret], Le, Vdb, StackReg, State) -> %% {[Ainstr],StackReg,State}. internal_cg(bs_context_to_binary=Instr, [Src0], [], Le, Vdb, Bef, St0) -> [Src] = cg_reg_args([Src0], Bef), - case is_register(Src) of - false -> - {[],clear_dead(Bef, Le#l.i, Vdb), St0}; - true -> - {[{Instr,Src}],clear_dead(Bef, Le#l.i, Vdb), St0} - end; + {[{Instr,Src}],clear_dead(Bef, Le#l.i, Vdb), St0}; internal_cg(dsetelement, [Index0,Tuple0,New0], _Rs, Le, Vdb, Bef, St0) -> [New,Tuple,{integer,Index1}] = cg_reg_args([New0,Tuple0,Index0], Bef), Index = Index1-1, @@ -1352,8 +1829,8 @@ internal_cg(dsetelement, [Index0,Tuple0,New0], _Rs, Le, Vdb, Bef, St0) -> clear_dead(Bef, Le#l.i, Vdb), St0}; internal_cg(make_fun, [Func0,Arity0|As], Rs, Le, Vdb, Bef, St0) -> %% This behaves more like a function call. - {atom,Func} = Func0, - {integer,Arity} = Arity0, + #k_atom{val=Func} = Func0, + #k_int{val=Arity} = Arity0, {Sis,Int} = cg_setup_call(As, Bef, Le#l.i, Vdb), Reg = load_vars(Rs, clear_regs(Int#sr.reg)), {FuncLbl,St1} = local_func_label(Func, Arity, St0), @@ -1366,14 +1843,35 @@ internal_cg(bs_init_writable=I, As, Rs, Le, Vdb, Bef, St) -> {Sis,Int} = cg_setup_call(As, Bef, Le#l.i, Vdb), Reg = load_vars(Rs, clear_regs(Int#sr.reg)), {Sis++[I],clear_dead(Int#sr{reg=Reg}, Le#l.i, Vdb),St}; +internal_cg(build_stacktrace=I, As, Rs, Le, Vdb, Bef, St) -> + %% This behaves like a function call. + {Sis,Int} = cg_setup_call(As, Bef, Le#l.i, Vdb), + Reg = load_vars(Rs, clear_regs(Int#sr.reg)), + {Sis++[I],clear_dead(Int#sr{reg=Reg}, Le#l.i, Vdb),St}; internal_cg(raise, As, Rs, Le, Vdb, Bef, St) -> %% raise can be treated like a guard BIF. - bif_cg(raise, As, Rs, Le, Vdb, Bef, St). + bif_cg(raise, As, Rs, Le, Vdb, Bef, St); +internal_cg(guard_error, [ExitCall], _Rs, Le, Vdb, Bef, St) -> + %% A call an exit BIF from inside a #k_guard_match{}. + %% Generate a standard call, but leave the register descriptors + %% alone, effectively pretending that there was no call. + #k_call{op=#k_remote{mod=#k_atom{val=Mod},name=#k_atom{val=Name}}, + args=As} = ExitCall, + Arity = length(As), + {Ms,_} = cg_call_args(As, Bef, Le#l.i, Vdb), + Call = {call_ext,Arity,{extfunc,Mod,Name,Arity}}, + Is = Ms++[line(Le),Call], + {Is,Bef,St}; +internal_cg(raw_raise=I, As, Rs, Le, Vdb, Bef, St) -> + %% This behaves like a function call. + {Sis,Int} = cg_setup_call(As, Bef, Le#l.i, Vdb), + Reg = load_vars(Rs, clear_regs(Int#sr.reg)), + {Sis++[I],clear_dead(Int#sr{reg=Reg}, Le#l.i, Vdb),St}. %% bif_cg(Bif, [Arg], [Ret], Le, Vdb, StackReg, State) -> %% {[Ainstr],StackReg,State}. -bif_cg(Bif, As, [{var,V}], Le, Vdb, Bef, St0) -> +bif_cg(Bif, As, [#k_var{name=V}], Le, Vdb, Bef, St0) -> Ars = cg_reg_args(As, Bef), %% If we are inside a catch and in a body (not in guard) and the @@ -1411,7 +1909,7 @@ bif_cg(Bif, As, [{var,V}], Le, Vdb, Bef, St0) -> %% gc_bif_cg(Bif, [Arg], [Ret], Le, Vdb, StackReg, State) -> %% {[Ainstr],StackReg,State}. -gc_bif_cg(Bif, As, [{var,V}], Le, Vdb, Bef, St0) -> +gc_bif_cg(Bif, As, [#k_var{name=V}], Le, Vdb, Bef, St0) -> Ars = cg_reg_args(As, Bef), %% If we are inside a catch and in a body (not in guard) and the @@ -1457,7 +1955,7 @@ recv_loop_cg(Te, Rvar, Rm, Tes, Rs, Le, Vdb, Bef, St0) -> %% cg_recv_mesg( ) -> {[Ainstr],Aft,St}. -cg_recv_mesg({var,R}, Rm, Tl, Bef, St0) -> +cg_recv_mesg(#k_var{name=R}, Rm, Tl, Bef, St0) -> Int0 = Bef#sr{reg=put_reg(R, Bef#sr.reg)}, Ret = fetch_reg(R, Int0#sr.reg), %% Int1 = clear_dead(Int0, I, Rm#l.vdb), @@ -1467,22 +1965,22 @@ cg_recv_mesg({var,R}, Rm, Tl, Bef, St0) -> %% cg_recv_wait(Te, Tes, I, Vdb, Int2, St3) -> {[Ainstr],Aft,St}. -cg_recv_wait({atom,infinity}, Tes, I, Bef, St0) -> +cg_recv_wait(#k_atom{val=infinity}, #cg_block{anno=Le,es=Tes}, I, Bef, St0) -> %% We know that the 'after' body will never be executed. %% But to keep the stack and register information up to date, %% we will generate the code for the 'after' body, and then discard it. - Int1 = clear_dead(Bef, I, Tes#l.vdb), - {_,Int2,St1} = cg_block(Tes#l.ke, Tes#l.i, Tes#l.vdb, - Int1#sr{reg=clear_regs(Int1#sr.reg)}, St0), + Int1 = clear_dead(Bef, I, Le#l.vdb), + {_,Int2,St1} = cg_block(Tes, Le#l.vdb, + Int1#sr{reg=clear_regs(Int1#sr.reg)}, St0), {[{wait,{f,St1#cg.recv}}],Int2,St1}; -cg_recv_wait({integer,0}, Tes, _I, Bef, St0) -> - {Tis,Int,St1} = cg_block(Tes#l.ke, Tes#l.i, Tes#l.vdb, Bef, St0), +cg_recv_wait(#k_int{val=0}, #cg_block{anno=Le,es=Tes}, _I, Bef, St0) -> + {Tis,Int,St1} = cg_block(Tes, Le#l.vdb, Bef, St0), {[timeout|Tis],Int,St1}; -cg_recv_wait(Te, Tes, I, Bef, St0) -> +cg_recv_wait(Te, #cg_block{anno=Le,es=Tes}, I, Bef, St0) -> Reg = cg_reg_arg(Te, Bef), %% Must have empty registers here! Bug if anything in registers. - Int0 = clear_dead(Bef, I, Tes#l.vdb), - {Tis,Int,St1} = cg_block(Tes#l.ke, Tes#l.i, Tes#l.vdb, + Int0 = clear_dead(Bef, I, Le#l.vdb), + {Tis,Int,St1} = cg_block(Tes, Le#l.vdb, Int0#sr{reg=clear_regs(Int0#sr.reg)}, St0), {[{wait_timeout,{f,St1#cg.recv},Reg},timeout] ++ Tis,Int,St1}. @@ -1500,7 +1998,7 @@ try_cg(Ta, Vs, Tb, Evs, Th, Rs, Le, Vdb, Bef, St0) -> {B,St1} = new_label(St0), %Body label {H,St2} = new_label(St1), %Handler label {E,St3} = new_label(St2), %End label - TryTag = Ta#l.i, + #l{i=TryTag} = get_kanno(Ta), Int1 = Bef#sr{stk=put_catch(TryTag, Bef#sr.stk)}, TryReg = fetch_stack({catch_tag,TryTag}, Int1#sr.stk), {Ais,Int2,St4} = cg(Ta, Vdb, Int1, St3#cg{break=B,in_catch=true}), @@ -1520,7 +2018,7 @@ try_cg(Ta, Vs, Tb, Evs, Th, Rs, Le, Vdb, Bef, St0) -> try_enter_cg(Ta, Vs, Tb, Evs, Th, Le, Vdb, Bef, St0) -> {B,St1} = new_label(St0), %Body label {H,St2} = new_label(St1), %Handler label - TryTag = Ta#l.i, + #l{i=TryTag} = get_kanno(Ta), Int1 = Bef#sr{stk=put_catch(TryTag, Bef#sr.stk)}, TryReg = fetch_stack({catch_tag,TryTag}, Int1#sr.stk), {Ais,Int2,St3} = cg(Ta, Vdb, Int1, St2#cg{break=B,in_catch=true}), @@ -1538,12 +2036,12 @@ try_enter_cg(Ta, Vs, Tb, Evs, Th, Le, Vdb, Bef, St0) -> %% catch_cg(CatchBlock, Ret, Le, Vdb, Bef, St) -> {[Ainstr],Aft,St}. -catch_cg(C, {var,R}, Le, Vdb, Bef, St0) -> +catch_cg(#cg_block{es=C}, #k_var{name=R}, Le, Vdb, Bef, St0) -> {B,St1} = new_label(St0), CatchTag = Le#l.i, Int1 = Bef#sr{stk=put_catch(CatchTag, Bef#sr.stk)}, CatchReg = fetch_stack({catch_tag,CatchTag}, Int1#sr.stk), - {Cis,Int2,St2} = cg_block(C, Le#l.i, Le#l.vdb, Int1, + {Cis,Int2,St2} = cg_block(C, Le#l.vdb, Int1, St1#cg{break=B,in_catch=true}), [] = Int2#sr.reg, %Assertion. Aft = Int2#sr{reg=[{0,R}],stk=drop_catch(CatchTag, Int2#sr.stk)}, @@ -1552,8 +2050,8 @@ catch_cg(C, {var,R}, Le, Vdb, Bef, St0) -> clear_dead(Aft, Le#l.i, Vdb), St2#cg{break=St1#cg.break,in_catch=St1#cg.in_catch}}. -%% set_cg([Var], Constr, Le, Vdb, Bef, St) -> {[Ainstr],Aft,St}. -%% We have to be careful how a 'set' works. First the structure is +%% put_cg([Var], Constr, Le, Vdb, Bef, St) -> {[Ainstr],Aft,St}. +%% We have to be careful how a 'put' works. First the structure is %% built, then it is filled and finally things can be cleared. The %% annotation must reflect this and make sure that the return %% variable is allocated first. @@ -1561,13 +2059,14 @@ catch_cg(C, {var,R}, Le, Vdb, Bef, St0) -> %% put_list and put_map are atomic instructions, both of %% which can safely resuse one of the source registers as target. -set_cg([{var,R}], {cons,Es}, Le, Vdb, Bef, St) -> - [S1,S2] = cg_reg_args(Es, Bef), +put_cg([#k_var{name=R}], #k_cons{hd=Hd,tl=Tl}, Le, Vdb, Bef, St) -> + [S1,S2] = cg_reg_args([Hd,Tl], Bef), Int0 = clear_dead(Bef, Le#l.i, Vdb), Int1 = Int0#sr{reg=put_reg(R, Int0#sr.reg)}, Ret = fetch_reg(R, Int1#sr.reg), {[{put_list,S1,S2,Ret}], Int1, St}; -set_cg([{var,R}], {binary,Segs}, Le, Vdb, Bef, #cg{bfail=Bfail}=St) -> +put_cg([#k_var{name=R}], #k_binary{segs=Segs}, Le, Vdb, Bef, + #cg{bfail=Bfail}=St) -> %% At run-time, binaries are constructed in three stages: %% 1) First the size of the binary is calculated. %% 2) Then the binary is allocated. @@ -1595,7 +2094,9 @@ set_cg([{var,R}], {binary,Segs}, Le, Vdb, Bef, #cg{bfail=Bfail}=St) -> {Sis++Code,Aft,St}; %% Map: single variable key. -set_cg([{var,R}], {map,Op,Map,[{map_pair,{var,_}=K,V}]}, Le, Vdb, Bef, St0) -> +put_cg([#k_var{name=R}], #k_map{op=Op,var=Map, + es=[#k_map_pair{key=#k_var{}=K,val=V}]}, + Le, Vdb, Bef, St0) -> {Sis,Int0} = maybe_adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb, St0), SrcReg = cg_reg_arg_prefer_y(Map, Int0), @@ -1610,22 +2111,23 @@ set_cg([{var,R}], {map,Op,Map,[{map_pair,{var,_}=K,V}]}, Le, Vdb, Bef, St0) -> Aft = Aft0#sr{reg=put_reg(R, Aft0#sr.reg)}, Target = fetch_reg(R, Aft#sr.reg), - {Is,St1} = set_cg_map(Line, Op, SrcReg, Target, Live, List, St0), + {Is,St1} = put_cg_map(Line, Op, SrcReg, Target, Live, List, St0), {Sis++Is,Aft,St1}; %% Map: (possibly) multiple literal keys. -set_cg([{var,R}], {map,Op,Map,Es}, Le, Vdb, Bef, St0) -> +put_cg([#k_var{name=R}], #k_map{op=Op,var=Map,es=Es}, Le, Vdb, Bef, St0) -> %% assert key literals - [] = [Var||{map_pair,{var,_}=Var,_} <- Es], + [] = [Var || #k_map_pair{key=#k_var{}=Var} <- Es], {Sis,Int0} = maybe_adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb, St0), SrcReg = cg_reg_arg_prefer_y(Map, Int0), Line = line(Le#l.a), %% fetch registers for values to be put into the map - Pairs = [{K,V} || {_,K,V} <- Es], - List = flatmap(fun({K,V}) -> [K,cg_reg_arg(V,Int0)] end, Pairs), + List = flatmap(fun(#k_map_pair{key=K,val=V}) -> + [atomic(K),cg_reg_arg(V, Int0)] + end, Es), Live = max_reg(Bef#sr.reg), @@ -1634,16 +2136,16 @@ set_cg([{var,R}], {map,Op,Map,Es}, Le, Vdb, Bef, St0) -> Aft = Aft0#sr{reg=put_reg(R, Aft0#sr.reg)}, Target = fetch_reg(R, Aft#sr.reg), - {Is,St1} = set_cg_map(Line, Op, SrcReg, Target, Live, List, St0), + {Is,St1} = put_cg_map(Line, Op, SrcReg, Target, Live, List, St0), {Sis++Is,Aft,St1}; %% Everything else. -set_cg([{var,R}], Con, Le, Vdb, Bef, St) -> +put_cg([#k_var{name=R}], Con, Le, Vdb, Bef, St) -> %% Find a place for the return register first. Int = Bef#sr{reg=put_reg(R, Bef#sr.reg)}, Ret = fetch_reg(R, Int#sr.reg), Ais = case Con of - {tuple,Es} -> + #k_tuple{es=Es} -> [{put_tuple,length(Es),Ret}] ++ cg_build_args(Es, Bef); Other -> [{move,cg_reg_arg(Other, Int),Ret}] @@ -1651,7 +2153,7 @@ set_cg([{var,R}], Con, Le, Vdb, Bef, St) -> {Ais,clear_dead(Int, Le#l.i, Vdb),St}. -set_cg_map(Line, Op0, SrcReg, Target, Live, List, St0) -> +put_cg_map(Line, Op0, SrcReg, Target, Live, List, St0) -> Bfail = St0#cg.bfail, Fail = {f,St0#cg.bfail}, Op = case Op0 of @@ -1865,7 +2367,8 @@ cg_bin_opt_1([I|Is]) -> cg_bin_opt_1([]) -> []. -cg_bin_put({bin_seg,[],S0,U,T,Fs,[E0,Next]}, Fail, Bef) -> +cg_bin_put(#k_bin_seg{size=S0,unit=U,type=T,flags=Fs,seg=E0,next=Next}, + Fail, Bef) -> S1 = cg_reg_arg(S0, Bef), E1 = cg_reg_arg(E0, Bef), {Format,Op} = case T of @@ -1882,7 +2385,7 @@ cg_bin_put({bin_seg,[],S0,U,T,Fs,[E0,Next]}, Fail, Bef) -> utf -> [{Op,Fail,{field_flags,Fs},E1}|cg_bin_put(Next, Fail, Bef)] end; -cg_bin_put({bin_end,[]}, _, _) -> []. +cg_bin_put(#k_bin_end{}, _, _) -> []. cg_build_args(As, Bef) -> [{put,cg_reg_arg(A, Bef)} || A <- As]. @@ -1902,13 +2405,12 @@ break_cg(Bs, Le, Vdb, Bef, St) -> {Ms ++ [{jump,{f,St#cg.break}}], Int#sr{reg=clear_regs(Int#sr.reg)},St}. -guard_break_cg(Bs, Locked, #l{i=I}, Vdb, #sr{reg=Reg0}=Bef, St) -> - RegLocked = get_locked_regs(Reg0, Locked), - #sr{reg=Reg1} = Int = clear_dead(Bef#sr{reg=RegLocked}, I, Vdb), +guard_break_cg(Bs, #l{i=I}, Vdb, #sr{reg=Reg0}=Bef, St) -> + #sr{reg=Reg1} = Int = clear_dead(Bef, I, Vdb), Reg2 = trim_free(Reg1), NumLocked = length(Reg2), Moves0 = gen_moves(Bs, Bef, NumLocked, []), - Moves = order_moves(Moves0, find_scratch_reg(RegLocked)), + Moves = order_moves(Moves0, find_scratch_reg(Reg0)), {BreakVars,_} = mapfoldl(fun(_, RegNum) -> {{RegNum,gbreakvar},RegNum+1} end, length(Reg2), Bs), @@ -1916,31 +2418,17 @@ guard_break_cg(Bs, Locked, #l{i=I}, Vdb, #sr{reg=Reg0}=Bef, St) -> Aft = Int#sr{reg=Reg}, {Moves ++ [{jump,{f,St#cg.break}}],Aft,St}. -get_locked_regs([R|Rs0], Preserve) -> - case {get_locked_regs(Rs0, Preserve),R} of - {[],{_,V}} -> - case lists:member(V, Preserve) of - true -> [R]; - false -> [] - end; - {[],_} -> - []; - {Rs,_} -> - [R|Rs] - end; -get_locked_regs([], _) -> []. - %% cg_reg_arg(Arg0, Info) -> Arg %% cg_reg_args([Arg0], Info) -> [Arg] %% Convert argument[s] into registers. Literal values are returned unchanged. cg_reg_args(As, Bef) -> [cg_reg_arg(A, Bef) || A <- As]. -cg_reg_arg({var,V}, Bef) -> fetch_var(V, Bef); -cg_reg_arg(Literal, _) -> Literal. +cg_reg_arg(#k_var{name=V}, Bef) -> fetch_var(V, Bef); +cg_reg_arg(Literal, _) -> atomic(Literal). -cg_reg_arg_prefer_y({var,V}, Bef) -> fetch_var_prefer_y(V, Bef); -cg_reg_arg_prefer_y(Literal, _) -> Literal. +cg_reg_arg_prefer_y(#k_var{name=V}, Bef) -> fetch_var_prefer_y(V, Bef); +cg_reg_arg_prefer_y(Literal, _) -> atomic(Literal). %% cg_setup_call([Arg], Bef, Cur, Vdb) -> {[Instr],Aft}. %% Do the complete setup for a call/enter. @@ -1978,9 +2466,9 @@ cg_call_args(As, Bef, I, Vdb) -> load_arg_regs(Regs, As) -> load_arg_regs(Regs, As, 0). -load_arg_regs([_|Rs], [{var,V}|As], I) -> [{I,V}|load_arg_regs(Rs, As, I+1)]; +load_arg_regs([_|Rs], [#k_var{name=V}|As], I) -> [{I,V}|load_arg_regs(Rs, As, I+1)]; load_arg_regs([_|Rs], [A|As], I) -> [{I,A}|load_arg_regs(Rs, As, I+1)]; -load_arg_regs([], [{var,V}|As], I) -> [{I,V}|load_arg_regs([], As, I+1)]; +load_arg_regs([], [#k_var{name=V}|As], I) -> [{I,V}|load_arg_regs([], As, I+1)]; load_arg_regs([], [A|As], I) -> [{I,A}|load_arg_regs([], As, I+1)]; load_arg_regs(Rs, [], _) -> Rs. @@ -2016,12 +2504,13 @@ move_unsaved([], _, Regs, Acc) -> {Acc,Regs}. gen_moves(As, Sr) -> gen_moves(As, Sr, 0, []). -gen_moves([{var,V}|As], Sr, I, Acc) -> +gen_moves([#k_var{name=V}|As], Sr, I, Acc) -> case fetch_var(V, Sr) of {x,I} -> gen_moves(As, Sr, I+1, Acc); Reg -> gen_moves(As, Sr, I+1, [{move,Reg,{x,I}}|Acc]) end; -gen_moves([A|As], Sr, I, Acc) -> +gen_moves([A0|As], Sr, I, Acc) -> + A = atomic(A0), gen_moves(As, Sr, I+1, [{move,A,{x,I}}|Acc]); gen_moves([], _, _, Acc) -> lists:keysort(3, Acc). @@ -2069,21 +2558,21 @@ break_up_cycle1(Dst, [M|Path], LastMove) -> %% clear_dead(Sr, Until, Vdb) -> Aft. %% Remove all variables in Sr which have died AT ALL so far. -clear_dead(Sr, Until, Vdb) -> - Sr#sr{reg=clear_dead_reg(Sr, Until, Vdb), - stk=clear_dead_stk(Sr#sr.stk, Until, Vdb)}. +clear_dead(#sr{stk=Stk}=Sr0, Until, Vdb) -> + Sr = Sr0#sr{reg=clear_dead_reg(Sr0, Until, Vdb), + stk=clear_dead_stk(Stk, Until, Vdb)}, + reserve(Sr). clear_dead_reg(Sr, Until, Vdb) -> - Reg = [case R of - {_I,V} = IV -> - case vdb_find(V, Vdb) of - {V,_,L} when L > Until -> IV; - _ -> free %Remove anything else - end; - {reserved,_I,_V} = Reserved -> Reserved; - free -> free - end || R <- Sr#sr.reg], - reserve(Sr#sr.res, Reg, Sr#sr.stk). + [case R of + {_I,V} = IV -> + case vdb_find(V, Vdb) of + {V,_,L} when L > Until -> IV; + _ -> free %Remove anything else + end; + {reserved,_I,_V}=Reserved -> Reserved; + free -> free + end || R <- Sr#sr.reg]. clear_dead_stk(Stk, Until, Vdb) -> [case S of @@ -2155,16 +2644,25 @@ adjust_stack(Bef, Fb, Lf, Vdb) -> save_stack(Stk0, Fb, Lf, Vdb) -> %% New variables that are in use but not on stack. - New = [VFL || {V,F,L} = VFL <- Vdb, - F < Fb, - L >= Lf, - not on_stack(V, Stk0)], + New = new_not_on_stack(Stk0, Fb, Lf, Vdb), + %% Add new variables that are not just dropped immediately. %% N.B. foldr works backwards from the end!! Saves = [V || {V,_,_} <- keysort(3, New)], Stk1 = foldr(fun (V, Stk) -> put_stack(V, Stk) end, Stk0, Saves), {Stk1,Saves}. +%% new_not_on_stack(Stack, FirstBefore, LastFrom, Vdb) -> +%% [{Variable,First,Last}] +%% Return information about all variables that are used past current +%% point and that are not already on the stack. + +new_not_on_stack(Stk, Fb, Lf, Vdb) -> + [VFL || {V,F,L} = VFL <- Vdb, + F < Fb, + L >= Lf, + not on_stack(V, Stk)]. + %% saves([SaveVar], Reg, Stk) -> [{move,Reg,Stk}]. %% Generate move instructions to save variables onto stack. The %% stack/reg info used is that after the new stack has been made. @@ -2190,7 +2688,7 @@ fetch_var_prefer_y(V, #sr{reg=Reg,stk=Stk}) -> end. load_vars(Vs, Regs) -> - foldl(fun ({var,V}, Rs) -> put_reg(V, Rs) end, Regs, Vs). + foldl(fun (#k_var{name=V}, Rs) -> put_reg(V, Rs) end, Regs, Vs). %% put_reg(Val, Regs) -> Regs. %% find_reg(Val, Regs) -> {ok,r{R}} | error. @@ -2270,10 +2768,6 @@ find_stack(_, [], _) -> error. on_stack(V, Stk) -> keymember(V, 1, Stk). -is_register({x,_}) -> true; -is_register({yy,_}) -> true; -is_register(_) -> false. - %% put_catch(CatchTag, Stack) -> Stack' %% drop_catch(CatchTag, Stack) -> Stack' %% Special interface for putting and removing catch tags, to ensure that @@ -2291,6 +2785,16 @@ put_catch(Tag, [Other|Stk], Acc) -> drop_catch(Tag, [{{catch_tag,Tag}}|Stk]) -> [free|Stk]; drop_catch(Tag, [Other|Stk]) -> [Other|drop_catch(Tag, Stk)]. +%% atomic(Klit) -> Lit. +%% atomic_list([Klit]) -> [Lit]. + +atomic(#k_literal{val=V}) -> {literal,V}; +atomic(#k_int{val=I}) -> {integer,I}; +atomic(#k_float{val=F}) -> {float,F}; +atomic(#k_atom{val=A}) -> {atom,A}; +%%atomic(#k_char{val=C}) -> {char,C}; +atomic(#k_nil{}) -> nil. + %% new_label(St) -> {L,St}. new_label(#cg{lcount=Next}=St) -> @@ -2333,3 +2837,86 @@ flatmapfoldl(F, Accu0, [Hd|Tail]) -> {Rs,Accu2} = flatmapfoldl(F, Accu1, Tail), {R++Rs,Accu2}; flatmapfoldl(_, Accu, []) -> {[],Accu}. + +%% Keep track of life time for variables. +%% +%% init_vars([{var,VarName}]) -> Vdb. +%% new_vars([VarName], I, Vdb) -> Vdb. +%% use_vars([VarName], I, Vdb) -> Vdb. +%% add_var(VarName, F, L, Vdb) -> Vdb. +%% +%% The list of variable names for new_vars/3 and use_vars/3 +%% must be sorted. + +init_vars(Vs) -> + vdb_new(Vs). + +new_vars([], _, Vdb) -> Vdb; +new_vars([V], I, Vdb) -> vdb_store_new(V, {V,I,I}, Vdb); +new_vars(Vs, I, Vdb) -> vdb_update_vars(Vs, Vdb, I). + +use_vars([], _, Vdb) -> + Vdb; +use_vars([V], I, Vdb) -> + case vdb_find(V, Vdb) of + {V,F,L} when I > L -> vdb_update(V, {V,F,I}, Vdb); + {V,_,_} -> Vdb; + error -> vdb_store_new(V, {V,I,I}, Vdb) + end; +use_vars(Vs, I, Vdb) -> vdb_update_vars(Vs, Vdb, I). + +add_var(V, F, L, Vdb) -> + vdb_store_new(V, {V,F,L}, Vdb). + +%% vdb + +vdb_new(Vs) -> + ordsets:from_list([{V,0,0} || #k_var{name=V} <- Vs]). + +-type var() :: atom(). + +-spec vdb_find(var(), [vdb_entry()]) -> 'error' | vdb_entry(). + +vdb_find(V, Vdb) -> + case lists:keyfind(V, 1, Vdb) of + false -> error; + Vd -> Vd + end. + +vdb_update(V, Update, [{V,_,_}|Vdb]) -> + [Update|Vdb]; +vdb_update(V, Update, [Vd|Vdb]) -> + [Vd|vdb_update(V, Update, Vdb)]. + +vdb_store_new(V, New, [{V1,_,_}=Vd|Vdb]) when V > V1 -> + [Vd|vdb_store_new(V, New, Vdb)]; +vdb_store_new(V, New, [{V1,_,_}|_]=Vdb) when V < V1 -> + [New|Vdb]; +vdb_store_new(_, New, []) -> [New]. + +vdb_update_vars([V|_]=Vs, [{V1,_,_}=Vd|Vdb], I) when V > V1 -> + [Vd|vdb_update_vars(Vs, Vdb, I)]; +vdb_update_vars([V|Vs], [{V1,_,_}|_]=Vdb, I) when V < V1 -> + %% New variable. + [{V,I,I}|vdb_update_vars(Vs, Vdb, I)]; +vdb_update_vars([V|Vs], [{_,F,L}=Vd|Vdb], I) -> + %% Existing variable. + if + I > L -> [{V,F,I}|vdb_update_vars(Vs, Vdb, I)]; + true -> [Vd|vdb_update_vars(Vs, Vdb, I)] + end; +vdb_update_vars([V|Vs], [], I) -> + %% New variable. + [{V,I,I}|vdb_update_vars(Vs, [], I)]; +vdb_update_vars([], Vdb, _) -> Vdb. + +%% vdb_sub(Min, Max, Vdb) -> Vdb. +%% Extract variables which are used before and after Min. Lock +%% variables alive after Max. + +vdb_sub(Min, Max, Vdb) -> + [ if L >= Max -> {V,F,locked}; + true -> Vd + end || {V,F,L}=Vd <- Vdb, + F < Min, + L >= Min ]. diff --git a/lib/compiler/src/v3_core.erl b/lib/compiler/src/v3_core.erl index 20cb3343fb..6029b91cdc 100644 --- a/lib/compiler/src/v3_core.erl +++ b/lib/compiler/src/v3_core.erl @@ -920,8 +920,9 @@ try_exception(Ecs0, St0) -> %% Note that Tag is not needed for rethrow - it is already in Info. {Evs,St1} = new_vars(3, St0), % Tag, Value, Info {Ecs1,Ceps,St2} = clauses(Ecs0, St1), + Ecs2 = try_build_stacktrace(Ecs1, hd(Evs)), [_,Value,Info] = Evs, - LA = case Ecs1 of + LA = case Ecs2 of [] -> []; [C|_] -> get_lineno_anno(C) end, @@ -930,7 +931,7 @@ try_exception(Ecs0, St0) -> body=[#iprimop{anno=#a{}, %Must have an #a{} name=#c_literal{val=raise}, args=[Info,Value]}]}, - Hs = [#icase{anno=#a{anno=LA},args=[c_tuple(Evs)],clauses=Ecs1,fc=Ec}], + Hs = [#icase{anno=#a{anno=LA},args=[c_tuple(Evs)],clauses=Ecs2,fc=Ec}], {Evs,Ceps++Hs,St2}. try_after(As, St0) -> @@ -946,6 +947,25 @@ try_after(As, St0) -> Hs = [#icase{anno=#a{},args=[c_tuple(Evs)],clauses=[],fc=Ec}], {Evs,Hs,St1}. +try_build_stacktrace([#iclause{pats=Ps0,body=B0}=C0|Cs], RawStk) -> + [#c_tuple{es=[Class,Exc,Stk]}=Tup] = Ps0, + case Stk of + #c_var{name='_'} -> + %% Stacktrace variable is not used. Nothing to do. + [C0|try_build_stacktrace(Cs, RawStk)]; + _ -> + %% Add code to build the stacktrace. + Ps = [Tup#c_tuple{es=[Class,Exc,RawStk]}], + Call = #iprimop{anno=#a{}, + name=#c_literal{val=build_stacktrace}, + args=[RawStk]}, + Iset = #iset{var=Stk,arg=Call}, + B = [Iset|B0], + C = C0#iclause{pats=Ps,body=B}, + [C|try_build_stacktrace(Cs, RawStk)] + end; +try_build_stacktrace([], _) -> []. + %% expr_bin([ArgExpr], St) -> {[Arg],[PreExpr],St}. %% Flatten the arguments of a bin. Do this straight left to right! %% Note that ibinary needs to have its annotation wrapped in a #a{} @@ -2462,9 +2482,11 @@ cexpr(#icase{anno=A,args=Largs,clauses=Lcs,fc=Lfc}, As, St0) -> cexpr(#ireceive1{anno=A,clauses=Lcs}, As, St0) -> Exp = intersection(A#a.ns, As), %Exports {Ccs,St1} = cclauses(Lcs, Exp, St0), + True = #c_literal{val=true}, + Action = core_lib:make_values(lists:duplicate(1+length(Exp), True)), {#c_receive{anno=A#a.anno, clauses=Ccs, - timeout=#c_literal{val=infinity},action=#c_literal{val=true}}, + timeout=#c_literal{val=infinity},action=Action}, Exp,A#a.us,St1}; cexpr(#ireceive2{anno=A,clauses=Lcs,timeout=Lto,action=Les}, As, St0) -> Exp = intersection(A#a.ns, As), %Exports diff --git a/lib/compiler/src/v3_kernel.erl b/lib/compiler/src/v3_kernel.erl index cbc8bb1303..fd73e5a7dc 100644 --- a/lib/compiler/src/v3_kernel.erl +++ b/lib/compiler/src/v3_kernel.erl @@ -108,6 +108,7 @@ copy_anno(Kdst, Ksrc) -> -record(iclause, {anno=[],isub,osub,pats,guard,body}). -record(ireceive_accept, {anno=[],arg}). -record(ireceive_next, {anno=[],arg}). +-record(ignored, {anno=[]}). -type warning() :: term(). % XXX: REFINE @@ -160,11 +161,9 @@ function({#c_var{name={F,Arity}=FA},Body}, St0) -> {#ifun{anno=Ab,vars=Kvs,body=B0},[],St2} = expr(Body, new_sub(), St1), {B1,_,St3} = ubody(B0, return, St2), %%B1 = B0, St3 = St2, %Null second pass - {#k_fdef{anno=#k{us=[],ns=[],a=Ab}, - func=F,arity=Arity,vars=Kvs,body=B1},St3} + {make_fdef(#k{us=[],ns=[],a=Ab}, F, Arity, Kvs, B1),St3} catch - Class:Error -> - Stack = erlang:get_stacktrace(), + Class:Error:Stack -> io:fwrite("Function: ~w/~w\n", [F,Arity]), erlang:raise(Class, Error, Stack) end. @@ -490,7 +489,7 @@ make_alt(First0, Then0) -> Then1 = pre_seq(droplast(Then0), last(Then0)), First2 = make_protected(First1), Then2 = make_protected(Then1), - Body = #k_atom{val=ignored}, + Body = #ignored{}, First3 = #k_guard_clause{guard=First2,body=Body}, Then3 = #k_guard_clause{guard=Then2,body=Body}, First = #k_guard{clauses=[First3]}, @@ -2226,7 +2225,9 @@ ubody(E, return, St0) -> {Ea,Pa,St1} = force_atomic(E, St0), ubody(pre_seq(Pa, #ivalues{args=[Ea]}), return, St1) end; -ubody(E, {break,_Rs} = Break, St0) -> +ubody(#ignored{}, {break,_} = Break, St) -> + ubody(#ivalues{args=[]}, Break, St); +ubody(E, {break,[_]} = Break, St0) -> %%ok = io:fwrite("ubody ~w:~p~n", [?LINE,{E,Br}]), %% Exiting expressions need no trailing break. case is_exit_expr(E) of @@ -2234,6 +2235,16 @@ ubody(E, {break,_Rs} = Break, St0) -> false -> {Ea,Pa,St1} = force_atomic(E, St0), ubody(pre_seq(Pa, #ivalues{args=[Ea]}), Break, St1) + end; +ubody(E, {break,Rs}=Break, St0) -> + case is_exit_expr(E) of + true -> + uexpr(E, return, St0); + false -> + {Vs,St1} = new_vars(length(Rs), St0), + Iset = #iset{vars=Vs,arg=E}, + PreSeq = pre_seq([Iset], #ivalues{args=Vs}), + ubody(PreSeq, Break, St1) end. iletrec_funs(#iletrec{defs=Fs}, St0) -> @@ -2262,9 +2273,8 @@ iletrec_funs_gen(Fs, FreeVs, St) -> Arity0 = length(Vs), {Fb1,_,Lst1} = ubody(Fb0, return, Lst0#kern{ff={N,Arity0}}), Arity = Arity0 + length(FreeVs), - Fun = #k_fdef{anno=#k{us=[],ns=[],a=Fa}, - func=N,arity=Arity, - vars=Vs ++ FreeVs,body=Fb1}, + Fun = make_fdef(#k{us=[],ns=[],a=Fa}, N, Arity, + Vs++FreeVs, Fb1), Lst1#kern{funs=[Fun|Lst1#kern.funs]} end, St, Fs). @@ -2408,8 +2418,7 @@ uexpr(#ifun{anno=A,vars=Vs,body=B0}, {break,Rs}, St0) -> %% No id annotation. Must invent a fun name. new_fun_name(St1) end, - Fun = #k_fdef{anno=#k{us=[],ns=[],a=A},func=Fname,arity=Arity, - vars=Vs ++ Fvs,body=B1}, + Fun = make_fdef(#k{us=[],ns=[],a=A}, Fname, Arity, Vs++Fvs, B1), {#k_bif{anno=#k{us=Free,ns=lit_list_vars(Rs),a=A}, op=#k_internal{name=make_fun,arity=length(Free)+2}, args=[#k_atom{val=Fname},#k_int{val=Arity}|Fvs], @@ -2426,6 +2435,16 @@ uexpr(Lit, {break,Rs0}, St0) -> add_local_function(_, #kern{funs=ignore}=St) -> St; add_local_function(F, #kern{funs=Funs}=St) -> St#kern{funs=[F|Funs]}. +%% Make a #k_fdef{}, making sure that the body is always a #k_match{}. +make_fdef(Anno, Name, Arity, Vs, #k_match{}=Body) -> + #k_fdef{anno=Anno,func=Name,arity=Arity,vars=Vs,body=Body}; +make_fdef(Anno, Name, Arity, Vs, Body) -> + Ka = get_kanno(Body), + Match = #k_match{anno=#k{us=Ka#k.us,ns=[],a=Ka#k.a}, + vars=Vs,body=Body,ret=[]}, + #k_fdef{anno=Anno,func=Name,arity=Arity,vars=Vs,body=Match}. + + %% handle_reuse_annos([#k_var{}], State) -> State. %% In general, it is only safe to reuse a variable for a match context %% if the original value of the variable will no longer be needed. diff --git a/lib/compiler/src/v3_life.erl b/lib/compiler/src/v3_life.erl deleted file mode 100644 index be3ade47ff..0000000000 --- a/lib/compiler/src/v3_life.erl +++ /dev/null @@ -1,468 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1999-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% -%% -%% Purpose : Convert annotated kernel expressions to annotated beam format. - -%% This module creates beam format annotated with variable lifetime -%% information. Each thing is given an index and for each variable we -%% store the first and last index for its occurrence. The variable -%% database, VDB, attached to each thing is only relevant internally -%% for that thing. -%% -%% For nested things like matches the numbering continues locally and -%% the VDB for that thing refers to the variable usage within that -%% thing. Variables which live through a such a thing are internally -%% given a very large last index. Internally the indexes continue -%% after the index of that thing. This creates no problems as the -%% internal variable info never escapes and externally we only see -%% variable which are alive both before or after. -%% -%% This means that variables never "escape" from a thing and the only -%% way to get values from a thing is to "return" them, with 'break' or -%% 'return'. Externally these values become the return values of the -%% thing. This is no real limitation as most nested things have -%% multiple threads so working out a common best variable usage is -%% difficult. - --module(v3_life). - --export([module/2]). - --export([vdb_find/2]). - --import(lists, [member/2,map/2,reverse/1,sort/1]). --import(ordsets, [add_element/2,intersection/2,union/2]). - --include("v3_kernel.hrl"). --include("v3_life.hrl"). - --type fa() :: {atom(),arity()}. - -%% These are not defined in v3_kernel.hrl. -get_kanno(Kthing) -> element(2, Kthing). -%%set_kanno(Kthing, Anno) -> setelement(2, Kthing, Anno). - --spec module(#k_mdef{}, [compile:option()]) -> - {'ok',{module(),[fa()],[_],[_]}}. - -module(#k_mdef{name=M,exports=Es,attributes=As,body=Fs0}, _Opts) -> - Fs1 = functions(Fs0, []), - {ok,{M,Es,As,Fs1}}. - -functions([F|Fs], Acc) -> - functions(Fs, [function(F)|Acc]); -functions([], Acc) -> reverse(Acc). - -%% function(Kfunc) -> Func. - -function(#k_fdef{anno=#k{a=Anno},func=F,arity=Ar,vars=Vs,body=Kb}) -> - try - As = var_list(Vs), - Vdb0 = init_vars(As), - %% Force a top-level match! - B0 = case Kb of - #k_match{} -> Kb; - _ -> - Ka = get_kanno(Kb), - #k_match{anno=#k{us=Ka#k.us,ns=[],a=Ka#k.a}, - vars=Vs,body=Kb,ret=[]} - end, - {B1,_,Vdb1} = body(B0, 1, Vdb0), - {function,F,Ar,As,B1,Vdb1,Anno} - catch - Class:Error -> - Stack = erlang:get_stacktrace(), - io:fwrite("Function: ~w/~w\n", [F,Ar]), - erlang:raise(Class, Error, Stack) - end. - -%% body(Kbody, I, Vdb) -> {[Expr],MaxI,Vdb}. -%% Handle a body. - -body(#k_seq{arg=Ke,body=Kb}, I, Vdb0) -> - %%ok = io:fwrite("life ~w:~p~n", [?LINE,{Ke,I,Vdb0}]), - A = get_kanno(Ke), - Vdb1 = use_vars(union(A#k.us, A#k.ns), I, Vdb0), - {Es,MaxI,Vdb2} = body(Kb, I+1, Vdb1), - E = expr(Ke, I, Vdb2), - {[E|Es],MaxI,Vdb2}; -body(Ke, I, Vdb0) -> - %%ok = io:fwrite("life ~w:~p~n", [?LINE,{Ke,I,Vdb0}]), - A = get_kanno(Ke), - Vdb1 = use_vars(union(A#k.us, A#k.ns), I, Vdb0), - E = expr(Ke, I, Vdb1), - {[E],I,Vdb1}. - -%% protected(Kprotected, I, Vdb) -> Protected. -%% Only used in guards. - -protected(#k_protected{anno=A,arg=Ts,ret=Rs}, I, Vdb) -> - %% Lock variables that are alive before try and used afterwards. - %% Don't lock variables that are only used inside the protected - %% expression. - Pdb0 = vdb_sub(I, I+1, Vdb), - {T,MaxI,Pdb1} = body(Ts, I+1, Pdb0), - Pdb2 = use_vars(A#k.ns, MaxI+1, Pdb1), %Save "return" values - #l{ke={protected,T,var_list(Rs)},i=I,a=A#k.a,vdb=Pdb2}. - -%% expr(Kexpr, I, Vdb) -> Expr. - -expr(#k_test{anno=A,op=Op,args=As,inverted=Inverted}, I, _Vdb) -> - #l{ke={test,test_op(Op),atomic_list(As),Inverted},i=I,a=A#k.a}; -expr(#k_call{anno=A,op=Op,args=As,ret=Rs}, I, _Vdb) -> - #l{ke={call,call_op(Op),atomic_list(As),var_list(Rs)},i=I,a=A#k.a}; -expr(#k_enter{anno=A,op=Op,args=As}, I, _Vdb) -> - #l{ke={enter,call_op(Op),atomic_list(As)},i=I,a=A#k.a}; -expr(#k_bif{anno=A,op=Op,args=As,ret=Rs}, I, _Vdb) -> - Bif = k_bif(A, Op, As, Rs), - #l{ke=Bif,i=I,a=A#k.a}; -expr(#k_match{anno=A,body=Kb,ret=Rs}, I, Vdb) -> - %% Work out imported variables which need to be locked. - Mdb = vdb_sub(I, I+1, Vdb), - M = match(Kb, A#k.us, I+1, [], Mdb), - #l{ke={match,M,var_list(Rs)},i=I,vdb=use_vars(A#k.us, I+1, Mdb),a=A#k.a}; -expr(#k_guard_match{anno=A,body=Kb,ret=Rs}, I, Vdb) -> - %% Work out imported variables which need to be locked. - Mdb = vdb_sub(I, I+1, Vdb), - M = match(Kb, A#k.us, I+1, [], Mdb), - #l{ke={guard_match,M,var_list(Rs)},i=I,vdb=use_vars(A#k.us, I+1, Mdb),a=A#k.a}; -expr(#k_try{}=Try, I, Vdb) -> - body_try(Try, I, Vdb); -expr(#k_protected{}=Protected, I, Vdb) -> - protected(Protected, I, Vdb); -expr(#k_try_enter{anno=A,arg=Ka,vars=Vs,body=Kb,evars=Evs,handler=Kh}, I, Vdb) -> - %% Lock variables that are alive before the catch and used afterwards. - %% Don't lock variables that are only used inside the try. - Tdb0 = vdb_sub(I, I+1, Vdb), - %% This is the tricky bit. Lock variables in Arg that are used in - %% the body and handler. Add try tag 'variable'. - Ab = get_kanno(Kb), - Ah = get_kanno(Kh), - Tdb1 = use_vars(union(Ab#k.us, Ah#k.us), I+3, Tdb0), - Tdb2 = vdb_sub(I, I+2, Tdb1), - Vnames = fun (Kvar) -> Kvar#k_var.name end, %Get the variable names - {Aes,_,Adb} = body(Ka, I+2, add_var({catch_tag,I+1}, I+1, 1000000, Tdb2)), - {Bes,_,Bdb} = body(Kb, I+4, new_vars(sort(map(Vnames, Vs)), I+3, Tdb2)), - {Hes,_,Hdb} = body(Kh, I+4, new_vars(sort(map(Vnames, Evs)), I+3, Tdb2)), - #l{ke={try_enter,#l{ke={block,Aes},i=I+1,vdb=Adb,a=[]}, - var_list(Vs),#l{ke={block,Bes},i=I+3,vdb=Bdb,a=[]}, - var_list(Evs),#l{ke={block,Hes},i=I+3,vdb=Hdb,a=[]}}, - i=I,vdb=Tdb1,a=A#k.a}; -expr(#k_catch{anno=A,body=Kb,ret=[R]}, I, Vdb) -> - %% Lock variables that are alive before the catch and used afterwards. - %% Don't lock variables that are only used inside the catch. - %% Add catch tag 'variable'. - Cdb0 = vdb_sub(I, I+1, Vdb), - {Es,_,Cdb1} = body(Kb, I+1, add_var({catch_tag,I}, I, locked, Cdb0)), - #l{ke={'catch',Es,variable(R)},i=I,vdb=Cdb1,a=A#k.a}; -expr(#k_receive{anno=A,var=V,body=Kb,timeout=T,action=Ka,ret=Rs}, I, Vdb) -> - %% Work out imported variables which need to be locked. - Rdb = vdb_sub(I, I+1, Vdb), - M = match(Kb, add_element(V#k_var.name, A#k.us), I+1, [], - new_vars([V#k_var.name], I, Rdb)), - {Tes,_,Adb} = body(Ka, I+1, Rdb), - #l{ke={receive_loop,atomic(T),variable(V),M, - #l{ke=Tes,i=I+1,vdb=Adb,a=[]},var_list(Rs)}, - i=I,vdb=use_vars(A#k.us, I+1, Vdb),a=A#k.a}; -expr(#k_receive_accept{anno=A}, I, _Vdb) -> - #l{ke=receive_accept,i=I,a=A#k.a}; -expr(#k_receive_next{anno=A}, I, _Vdb) -> - #l{ke=receive_next,i=I,a=A#k.a}; -expr(#k_put{anno=A,arg=Arg,ret=Rs}, I, _Vdb) -> - #l{ke={set,var_list(Rs),literal(Arg, [])},i=I,a=A#k.a}; -expr(#k_break{anno=A,args=As}, I, _Vdb) -> - #l{ke={break,atomic_list(As)},i=I,a=A#k.a}; -expr(#k_guard_break{anno=A,args=As}, I, Vdb) -> - Locked = [V || {V,_,_} <- Vdb], - #l{ke={guard_break,atomic_list(As),Locked},i=I,a=A#k.a}; -expr(#k_return{anno=A,args=As}, I, _Vdb) -> - #l{ke={return,atomic_list(As)},i=I,a=A#k.a}. - -body_try(#k_try{anno=A,arg=Ka,vars=Vs,body=Kb,evars=Evs,handler=Kh,ret=Rs}, - I, Vdb) -> - %% Lock variables that are alive before the catch and used afterwards. - %% Don't lock variables that are only used inside the try. - Tdb0 = vdb_sub(I, I+1, Vdb), - %% This is the tricky bit. Lock variables in Arg that are used in - %% the body and handler. Add try tag 'variable'. - Ab = get_kanno(Kb), - Ah = get_kanno(Kh), - Tdb1 = use_vars(union(Ab#k.us, Ah#k.us), I+3, Tdb0), - Tdb2 = vdb_sub(I, I+2, Tdb1), - Vnames = fun (Kvar) -> Kvar#k_var.name end, %Get the variable names - {Aes,_,Adb} = body(Ka, I+2, add_var({catch_tag,I+1}, I+1, locked, Tdb2)), - {Bes,_,Bdb} = body(Kb, I+4, new_vars(sort(map(Vnames, Vs)), I+3, Tdb2)), - {Hes,_,Hdb} = body(Kh, I+4, new_vars(sort(map(Vnames, Evs)), I+3, Tdb2)), - #l{ke={'try',#l{ke={block,Aes},i=I+1,vdb=Adb,a=[]}, - var_list(Vs),#l{ke={block,Bes},i=I+3,vdb=Bdb,a=[]}, - var_list(Evs),#l{ke={block,Hes},i=I+3,vdb=Hdb,a=[]}, - var_list(Rs)}, - i=I,vdb=Tdb1,a=A#k.a}. - -%% call_op(Op) -> Op. -%% test_op(Op) -> Op. -%% Do any necessary name translations here to munge into beam format. - -call_op(#k_local{name=N}) -> N; -call_op(#k_remote{mod=M,name=N}) -> {remote,atomic(M),atomic(N)}; -call_op(Other) -> variable(Other). - -test_op(#k_remote{mod=#k_atom{val=erlang},name=#k_atom{val=N}}) -> N. - -%% k_bif(Anno, Op, [Arg], [Ret], Vdb) -> Expr. -%% Build bifs. - -k_bif(_A, #k_internal{name=Name}, As, Rs) -> - {internal,Name,atomic_list(As),var_list(Rs)}; -k_bif(_A, #k_remote{mod=#k_atom{val=erlang},name=#k_atom{val=Name}}, As, Rs) -> - Ar = length(As), - case is_gc_bif(Name, Ar) of - false -> - {bif,Name,atomic_list(As),var_list(Rs)}; - true -> - {gc_bif,Name,atomic_list(As),var_list(Rs)} - end. - -%% match(Kexpr, [LockVar], I, Vdb) -> Expr. -%% Convert match tree to old format. - -match(#k_alt{anno=A,first=Kf,then=Kt}, Ls, I, Ctxt, Vdb0) -> - Vdb1 = use_vars(union(A#k.us, Ls), I, Vdb0), - F = match(Kf, Ls, I+1, Ctxt, Vdb1), - T = match(Kt, Ls, I+1, Ctxt, Vdb1), - #l{ke={alt,F,T},i=I,vdb=Vdb1,a=A#k.a}; -match(#k_select{anno=A,var=V,types=Kts}, Ls0, I, Ctxt, Vdb0) -> - Vanno = get_kanno(V), - Ls1 = case member(no_usage, Vanno) of - false -> add_element(V#k_var.name, Ls0); - true -> Ls0 - end, - Anno = case member(reuse_for_context, Vanno) of - true -> [reuse_for_context|A#k.a]; - false -> A#k.a - end, - Vdb1 = use_vars(union(A#k.us, Ls1), I, Vdb0), - Ts = [type_clause(Tc, Ls1, I+1, Ctxt, Vdb1) || Tc <- Kts], - #l{ke={select,literal(V, Ctxt),Ts},i=I,vdb=Vdb1,a=Anno}; -match(#k_guard{anno=A,clauses=Kcs}, Ls, I, Ctxt, Vdb0) -> - Vdb1 = use_vars(union(A#k.us, Ls), I, Vdb0), - Cs = [guard_clause(G, Ls, I+1, Ctxt, Vdb1) || G <- Kcs], - #l{ke={guard,Cs},i=I,vdb=Vdb1,a=A#k.a}; -match(Other, Ls, I, _Ctxt, Vdb0) -> - Vdb1 = use_vars(Ls, I, Vdb0), - {B,_,Vdb2} = body(Other, I+1, Vdb1), - #l{ke={block,B},i=I,vdb=Vdb2,a=[]}. - -type_clause(#k_type_clause{anno=A,type=T,values=Kvs}, Ls, I, Ctxt, Vdb0) -> - %%ok = io:format("life ~w: ~p~n", [?LINE,{T,Kvs}]), - Vdb1 = use_vars(union(A#k.us, Ls), I+1, Vdb0), - Vs = [val_clause(Vc, Ls, I+1, Ctxt, Vdb1) || Vc <- Kvs], - #l{ke={type_clause,type(T),Vs},i=I,vdb=Vdb1,a=A#k.a}. - -val_clause(#k_val_clause{anno=A,val=V,body=Kb}, Ls0, I, Ctxt0, Vdb0) -> - New = (get_kanno(V))#k.ns, - Bus = (get_kanno(Kb))#k.us, - %%ok = io:format("Ls0 = ~p, Used=~p\n New=~p, Bus=~p\n", [Ls0,Used,New,Bus]), - Ls1 = union(intersection(New, Bus), Ls0), %Lock for safety - Vdb1 = use_vars(union(A#k.us, Ls1), I+1, new_vars(New, I, Vdb0)), - Ctxt = case V of - #k_binary{segs=#k_var{name=C0}} -> C0; - _ -> Ctxt0 - end, - B = match(Kb, Ls1, I+1, Ctxt, Vdb1), - #l{ke={val_clause,literal(V, Ctxt),B},i=I,vdb=use_vars(Bus, I+1, Vdb1),a=A#k.a}. - -guard_clause(#k_guard_clause{anno=A,guard=Kg,body=Kb}, Ls, I, Ctxt, Vdb0) -> - Vdb1 = use_vars(union(A#k.us, Ls), I+2, Vdb0), - Gdb = vdb_sub(I+1, I+2, Vdb1), - G = protected(Kg, I+1, Gdb), - B = match(Kb, Ls, I+2, Ctxt, Vdb1), - #l{ke={guard_clause,G,B}, - i=I,vdb=use_vars((get_kanno(Kg))#k.us, I+2, Vdb1), - a=A#k.a}. - -%% type(Ktype) -> Type. - -type(k_literal) -> literal; -type(k_int) -> integer; -%%type(k_char) -> integer; %Hhhmmm??? -type(k_float) -> float; -type(k_atom) -> atom; -type(k_nil) -> nil; -type(k_cons) -> cons; -type(k_tuple) -> tuple; -type(k_binary) -> binary; -type(k_bin_seg) -> bin_seg; -type(k_bin_int) -> bin_int; -type(k_bin_end) -> bin_end; -type(k_map) -> map. - -%% variable(Klit) -> Lit. -%% var_list([Klit]) -> [Lit]. - -variable(#k_var{name=N}) -> {var,N}. - -var_list(Ks) -> [variable(K) || K <- Ks]. - -%% atomic(Klit) -> Lit. -%% atomic_list([Klit]) -> [Lit]. - -atomic(#k_literal{val=V}) -> {literal,V}; -atomic(#k_var{name=N}) -> {var,N}; -atomic(#k_int{val=I}) -> {integer,I}; -atomic(#k_float{val=F}) -> {float,F}; -atomic(#k_atom{val=N}) -> {atom,N}; -%%atomic(#k_char{val=C}) -> {char,C}; -atomic(#k_nil{}) -> nil. - -atomic_list(Ks) -> [atomic(K) || K <- Ks]. - -%% literal(Klit) -> Lit. -%% literal_list([Klit]) -> [Lit]. - -literal(#k_var{name=N}, _) -> {var,N}; -literal(#k_literal{val=I}, _) -> {literal,I}; -literal(#k_int{val=I}, _) -> {integer,I}; -literal(#k_float{val=F}, _) -> {float,F}; -literal(#k_atom{val=N}, _) -> {atom,N}; -%%literal(#k_char{val=C}, _) -> {char,C}; -literal(#k_nil{}, _) -> nil; -literal(#k_cons{hd=H,tl=T}, Ctxt) -> - {cons,[literal(H, Ctxt),literal(T, Ctxt)]}; -literal(#k_binary{segs=V}, Ctxt) -> - {binary,literal(V, Ctxt)}; -literal(#k_bin_seg{size=S,unit=U,type=T,flags=Fs,seg=Seg,next=[]}, Ctxt) -> - %% Only occurs in patterns. - {bin_seg,Ctxt,literal(S, Ctxt),U,T,Fs,[literal(Seg, Ctxt)]}; -literal(#k_bin_seg{size=S,unit=U,type=T,flags=Fs,seg=Seg,next=N}, Ctxt) -> - {bin_seg,Ctxt,literal(S, Ctxt),U,T,Fs, - [literal(Seg, Ctxt),literal(N, Ctxt)]}; -literal(#k_bin_int{size=S,unit=U,flags=Fs,val=Int,next=N}, Ctxt) -> - %% Only occurs in patterns. - {bin_int,Ctxt,literal(S, Ctxt),U,Fs,Int, - [literal(N, Ctxt)]}; -literal(#k_bin_end{}, Ctxt) -> - {bin_end,Ctxt}; -literal(#k_tuple{es=Es}, Ctxt) -> - {tuple,literal_list(Es, Ctxt)}; -literal(#k_map{op=Op,var=Var,es=Es0}, Ctxt) -> - {map,Op,literal(Var, Ctxt),literal_list(Es0, Ctxt)}; -literal(#k_map_pair{key=K,val=V}, Ctxt) -> - {map_pair,literal(K, Ctxt),literal(V, Ctxt)}. - -literal_list(Ks, Ctxt) -> - [literal(K, Ctxt) || K <- Ks]. - - -%% is_gc_bif(Name, Arity) -> true|false -%% Determines whether the BIF Name/Arity might do a GC. - -is_gc_bif(hd, 1) -> false; -is_gc_bif(tl, 1) -> false; -is_gc_bif(self, 0) -> false; -is_gc_bif(node, 0) -> false; -is_gc_bif(node, 1) -> false; -is_gc_bif(element, 2) -> false; -is_gc_bif(get, 1) -> false; -is_gc_bif(tuple_size, 1) -> false; -is_gc_bif(Bif, Arity) -> - not (erl_internal:bool_op(Bif, Arity) orelse - erl_internal:new_type_test(Bif, Arity) orelse - erl_internal:comp_op(Bif, Arity)). - -%% Keep track of life time for variables. -%% -%% init_vars([{var,VarName}]) -> Vdb. -%% new_vars([VarName], I, Vdb) -> Vdb. -%% use_vars([VarName], I, Vdb) -> Vdb. -%% add_var(VarName, F, L, Vdb) -> Vdb. -%% -%% The list of variable names for new_vars/3 and use_vars/3 -%% must be sorted. - -init_vars(Vs) -> - vdb_new(Vs). - -new_vars([], _, Vdb) -> Vdb; -new_vars([V], I, Vdb) -> vdb_store_new(V, {V,I,I}, Vdb); -new_vars(Vs, I, Vdb) -> vdb_update_vars(Vs, Vdb, I). - -use_vars([], _, Vdb) -> - Vdb; -use_vars([V], I, Vdb) -> - case vdb_find(V, Vdb) of - {V,F,L} when I > L -> vdb_update(V, {V,F,I}, Vdb); - {V,_,_} -> Vdb; - error -> vdb_store_new(V, {V,I,I}, Vdb) - end; -use_vars(Vs, I, Vdb) -> vdb_update_vars(Vs, Vdb, I). - -add_var(V, F, L, Vdb) -> - vdb_store_new(V, {V,F,L}, Vdb). - -%% vdb - -vdb_new(Vs) -> - sort([{V,0,0} || {var,V} <- Vs]). - --type var() :: atom(). - --spec vdb_find(var(), [vdb_entry()]) -> 'error' | vdb_entry(). - -vdb_find(V, Vdb) -> - case lists:keyfind(V, 1, Vdb) of - false -> error; - Vd -> Vd - end. - -vdb_update(V, Update, [{V,_,_}|Vdb]) -> - [Update|Vdb]; -vdb_update(V, Update, [Vd|Vdb]) -> - [Vd|vdb_update(V, Update, Vdb)]. - -vdb_store_new(V, New, [{V1,_,_}=Vd|Vdb]) when V > V1 -> - [Vd|vdb_store_new(V, New, Vdb)]; -vdb_store_new(V, New, [{V1,_,_}|_]=Vdb) when V < V1 -> - [New|Vdb]; -vdb_store_new(_, New, []) -> [New]. - -vdb_update_vars([V|_]=Vs, [{V1,_,_}=Vd|Vdb], I) when V > V1 -> - [Vd|vdb_update_vars(Vs, Vdb, I)]; -vdb_update_vars([V|Vs], [{V1,_,_}|_]=Vdb, I) when V < V1 -> - %% New variable. - [{V,I,I}|vdb_update_vars(Vs, Vdb, I)]; -vdb_update_vars([V|Vs], [{_,F,L}=Vd|Vdb], I) -> - %% Existing variable. - if - I > L -> [{V,F,I}|vdb_update_vars(Vs, Vdb, I)]; - true -> [Vd|vdb_update_vars(Vs, Vdb, I)] - end; -vdb_update_vars([V|Vs], [], I) -> - %% New variable. - [{V,I,I}|vdb_update_vars(Vs, [], I)]; -vdb_update_vars([], Vdb, _) -> Vdb. - -%% vdb_sub(Min, Max, Vdb) -> Vdb. -%% Extract variables which are used before and after Min. Lock -%% variables alive after Max. - -vdb_sub(Min, Max, Vdb) -> - [ if L >= Max -> {V,F,locked}; - true -> Vd - end || {V,F,L}=Vd <- Vdb, F < Min, L >= Min ]. diff --git a/lib/compiler/test/beam_block_SUITE.erl b/lib/compiler/test/beam_block_SUITE.erl index 55d5f2dbe8..38ead96cc8 100644 --- a/lib/compiler/test/beam_block_SUITE.erl +++ b/lib/compiler/test/beam_block_SUITE.erl @@ -22,7 +22,7 @@ -export([all/0,suite/0,groups/0,init_per_suite/1,end_per_suite/1, init_per_group/2,end_per_group/2, get_map_elements/1,otp_7345/1,move_opt_across_gc_bif/1, - erl_202/1,repro/1]). + erl_202/1,repro/1,local_cse/1,second_block_pass/1]). %% The only test for the following functions is that %% the code compiles and is accepted by beam_validator. @@ -40,7 +40,9 @@ groups() -> otp_7345, move_opt_across_gc_bif, erl_202, - repro + repro, + local_cse, + second_block_pass ]}]. init_per_suite(Config) -> @@ -237,6 +239,72 @@ find_operands(Cfg,XsiGraph,ActiveList,Count) -> [Count+1, length(NewActiveList), length(digraph:vertices(XsiGraph))], find_operands(NewCfg,XsiGraph,NewActiveList,Count+1). +%% Some tests of local common subexpression elimination (CSE). + +local_cse(_Config) -> + {Self,{ok,Self}} = local_cse_1(), + + local_cse_2([]), + local_cse_2(lists:seq(1, 512)), + local_cse_2(?MODULE:module_info()), + + {[b],[a,b]} = local_cse_3(a, b), + + {2000,Self,{Self,write_cache}} = local_cse_4(), + + ok. + +local_cse_1() -> + %% Cover handling of unsafe tuple construction in + %% eliminate_use_of_from_reg/4. It became necessary to handle + %% unsafe tuples when local CSE was introduced. + + {self(),{ok,self()}}. + +local_cse_2(Term) -> + case cse_make_binary(Term) of + <<Size:8,BinTerm:Size/binary>> -> + Term = binary_to_term(BinTerm); + <<Size:8,SizeTerm:Size/binary,BinTerm/binary>> -> + {'$size',TermSize} = binary_to_term(SizeTerm), + TermSize = byte_size(BinTerm), + Term = binary_to_term(BinTerm) + end. + +%% Copy of observer_backend:ttb_make_binary/1. During development of +%% the local CSE optimization this function was incorrectly optimized. + +cse_make_binary(Term) -> + B = term_to_binary(Term), + SizeB = byte_size(B), + if SizeB > 255 -> + SB = term_to_binary({'$size',SizeB}), + <<(byte_size(SB)):8, SB/binary, B/binary>>; + true -> + <<SizeB:8, B/binary>> + end. + +local_cse_3(X, Y) -> + %% The following expression was incorrectly transformed to {[X,Y],[X,Y]} + %% during development of the local CSE optimization. + + {[Y],[X,Y]}. + +local_cse_4() -> + do_local_cse_4(2000, self(), {self(), write_cache}). + +do_local_cse_4(X, Y, Z) -> + {X,Y,Z}. + +%% Tests previously found bugs when running beam_block the second time. + +second_block_pass(_Config) -> + [#{dts:=5.0}] = second_1([#{dts => 10.0}], 2.0), + ok. + +second_1(Fs, TS) -> + [F#{dts=>DTS / TS} || #{dts:=DTS} = F <- Fs]. + %%% %%% Common functions. %%% diff --git a/lib/compiler/test/beam_type_SUITE.erl b/lib/compiler/test/beam_type_SUITE.erl index 86146c614f..e33df809ff 100644 --- a/lib/compiler/test/beam_type_SUITE.erl +++ b/lib/compiler/test/beam_type_SUITE.erl @@ -22,7 +22,8 @@ -export([all/0,suite/0,groups/0,init_per_suite/1,end_per_suite/1, init_per_group/2,end_per_group/2, integers/1,coverage/1,booleans/1,setelement/1,cons/1, - tuple/1,record_float/1,binary_float/1,float_compare/1]). + tuple/1,record_float/1,binary_float/1,float_compare/1, + arity_checks/1,elixir_binaries/1]). suite() -> [{ct_hooks,[ts_install_cth]}]. @@ -40,7 +41,9 @@ groups() -> tuple, record_float, binary_float, - float_compare + float_compare, + arity_checks, + elixir_binaries ]}]. init_per_suite(Config) -> @@ -64,6 +67,15 @@ integers(_Config) -> college = do_integers_3(), + zero = do_integers_4(<<0:1>>, 0), + one = do_integers_4(<<1:1>>, 0), + other = do_integers_4(<<1:1>>, 2), + + zero = do_integers_5(0, 0), + one = do_integers_5(0, 1), + two = do_integers_5(0, 2), + three = do_integers_5(0, 3), + ok. do_integers_1(B0) -> @@ -86,6 +98,30 @@ do_integers_3() -> 1 -> 0 end. +do_integers_4(<<X:1,T/bits>>, C) -> + %% Binary matching gives the range 0-1 for X. + %% The range for `X bor C` is unknown. It must not be inherited + %% from X. (`X bor C` will reuse the register used for X.) + case X bor C of + 0 -> do_integers_4(T, C, zero); + 1 -> do_integers_4(T, C, one); + _ -> do_integers_4(T, C, other) + end. + +do_integers_4(_, _, Res) -> + Res. + +do_integers_5(X0, Y0) -> + %% X and Y will use the same register. + X = X0 band 1, + Y = Y0 band 3, + case Y of + 0 -> zero; + 1 -> one; + 2 -> two; + 3 -> three + end. + coverage(_Config) -> {'EXIT',{badarith,_}} = (catch id(1) bsl 0.5), {'EXIT',{badarith,_}} = (catch id(2.0) bsl 2), @@ -171,6 +207,68 @@ do_float_compare(X) -> _T -> Y > 0 end. +arity_checks(_Config) -> + %% ERL-549: an unsafe optimization removed a test_arity instruction, + %% causing the following to return 'broken' instead of 'ok'. + ok = do_record_arity_check({rgb, 255, 255, 255, 1}), + ok = do_tuple_arity_check({255, 255, 255, 1}). + +-record(rgb, {r = 255, g = 255, b = 255}). + +do_record_arity_check(RGB) when + (element(2, RGB) >= 0), (element(2, RGB) =< 255), + (element(3, RGB) >= 0), (element(3, RGB) =< 255), + (element(4, RGB) >= 0), (element(4, RGB) =< 255) -> + if + element(1, RGB) =:= rgb, is_record(RGB, rgb) -> broken; + true -> ok + end. + +do_tuple_arity_check(RGB) when is_tuple(RGB), + (element(1, RGB) >= 0), (element(1, RGB) =< 255), + (element(2, RGB) >= 0), (element(2, RGB) =< 255), + (element(3, RGB) >= 0), (element(3, RGB) =< 255) -> + case RGB of + {255, _, _} -> broken; + _ -> ok + end. + +elixir_binaries(_Config) -> + <<"foo blitzky baz">> = elixir_binary_1(<<"blitzky">>), + <<"foo * baz">> = elixir_binary_2($*), + <<7:4,755:10>> = elixir_bitstring_3(<<755:10>>), + ok. + +elixir_binary_1(Bar) when is_binary(Bar) -> + <<"foo ", + case Bar of + Rewrite when is_binary(Rewrite) -> + Rewrite; + Rewrite -> + list_to_binary(Rewrite) + end/binary, + " baz">>. + +elixir_binary_2(Arg) -> + Bin = <<Arg>>, + <<"foo ", + case Bin of + Rewrite when is_binary(Rewrite) -> + Rewrite; + Rewrite -> + list_to_binary:to_string(Rewrite) + end/binary, + " baz">>. + +elixir_bitstring_3(Bar) when is_bitstring(Bar) -> + <<7:4, + case Bar of + Rewrite when is_bitstring(Rewrite) -> + Rewrite; + Rewrite -> + list_to_bitstring(Rewrite) + end/bitstring>>. + id(I) -> I. diff --git a/lib/compiler/test/beam_utils_SUITE.erl b/lib/compiler/test/beam_utils_SUITE.erl index 710cb050d4..7686e69b63 100644 --- a/lib/compiler/test/beam_utils_SUITE.erl +++ b/lib/compiler/test/beam_utils_SUITE.erl @@ -24,7 +24,8 @@ apply_fun/1,apply_mf/1,bs_init/1,bs_save/1, is_not_killed/1,is_not_used_at/1, select/1,y_catch/1,otp_8949_b/1,liveopt/1,coverage/1, - y_registers/1]). + y_registers/1,user_predef/1,scan_f/1,cafu/1, + receive_label/1,read_size_file_version/1]). -export([id/1]). suite() -> [{ct_hooks,[ts_install_cth]}]. @@ -46,7 +47,11 @@ groups() -> otp_8949_b, liveopt, coverage, - y_registers + y_registers, + user_predef, + scan_f, + cafu, + read_size_file_version ]}]. init_per_suite(Config) -> @@ -117,6 +122,15 @@ bs_init(_Config) -> {'EXIT',{badarg,_}} = (catch do_bs_init_2([0.5])), {'EXIT',{badarg,_}} = (catch do_bs_init_2([-1])), {'EXIT',{badarg,_}} = (catch do_bs_init_2([1 bsl 32])), + + <<>> = do_bs_init_3({tag,0}, 0, 0), + <<0>> = do_bs_init_3({tag,0}, 2, 1), + + <<"_build/shared">> = do_bs_init_4([], false), + <<"abc/shared">> = do_bs_init_4(<<"abc">>, false), + <<"foo/foo">> = do_bs_init_4(<<"foo">>, true), + error = do_bs_init_4([], not_boolean), + ok. do_bs_init_1([?MODULE], Sz) -> @@ -134,6 +148,45 @@ do_bs_init_2(SigNos) -> erlang:error(badarg) >>. +do_bs_init_3({tag,Pos}, Offset, Len) -> + N0 = Offset - Pos, + N = if N0 > Len -> Len; + true -> N0 + end, + <<0:N/unit:8>>. + +do_bs_init_4(Arg1, Arg2) -> + Build = + case id(Arg1) of + X when X =:= [] orelse X =:= false -> <<"_build">>; + X -> X + end, + case id(Arg2) of + true -> + id(<<case Build of + Rewrite when is_binary(Rewrite) -> + Rewrite; + Rewrite -> + id(Rewrite) + end/binary, + "/", + case id(<<"foo">>) of + Rewrite when is_binary(Rewrite) -> + Rewrite; + Rewrite -> + id(Rewrite) + end/binary>>); + false -> + id(<<case Build of + Rewrite when is_binary(Rewrite) -> + Rewrite; + Rewrite -> + id(Rewrite) + end/binary, + "/shared">>); + Other -> + error + end. bs_save(_Config) -> {a,30,<<>>} = do_bs_save(<<1:1,30:5>>), @@ -376,5 +429,83 @@ do(A, B) -> {A,B}. appointment(#{"resolution" := Url}) -> do(receive _ -> Url end, #{true => Url}). +%% From epp.erl. +user_predef(_Config) -> + #{key:="value"} = user_predef({key,"value"}, #{}), + #{key:="value"} = user_predef({key,"value"}, #{key=>defined}), + error = user_predef({key,"value"}, #{key=>[defined]}), + ok. + +user_predef({M,Val}, Ms) -> + case Ms of + #{M:=Defs} when is_list(Defs) -> + error; + _ -> + Ms#{M=>Val} + end. + +%% From disk_log_1.erl. +scan_f(_Config) -> + {1,<<>>,[]} = scan_f(<<1:32>>, 1, []), + {1,<<>>,[<<156>>]} = scan_f(<<1:32,156,1:32>>, 1, []), + ok. + +scan_f(<<Size:32,Tail/binary>>, FSz, Acc) when Size =< FSz -> + case Tail of + <<BinTerm:Size/binary,Tail2/binary>> -> + scan_f(Tail2, FSz, [BinTerm | Acc]); + _ -> + {Size,Tail,Acc} + end. + +%% From file_io_server.erl. +cafu(_Config) -> + error = cafu(<<42:32>>, -1, 0, {utf32,big}), + error = cafu(<<42:32>>, 10, 0, {utf32,big}), + error = cafu(<<42:32>>, -1, 0, {utf32,little}), + ok. + +cafu(<<_/big-utf32,Rest/binary>>, N, Count, {utf32,big}) when N < 0 -> + cafu(Rest, -1, Count+1, {utf32,big}); +cafu(<<_/big-utf32,Rest/binary>>, N, Count, {utf32,big}) -> + cafu(Rest, N-1, Count+1, {utf32,big}); +cafu(<<_/little-utf32,Rest/binary>>, N, Count, {utf32,little}) when N < 0 -> + cafu(Rest, -1, Count+1, {utf32,little}); +cafu(_, _, _, _) -> + error. + +-record(rec_label, {bool}). + +receive_label(_Config) -> + Pid = spawn_link(fun() -> do_receive_label(#rec_label{bool=true}) end), + Msg = {a,b,c}, + Pid ! {self(),Msg}, + receive + {ok,Msg} -> + unlink(Pid), + exit(Pid, die), + ok + end. + +do_receive_label(Rec) -> + receive + {From,Message} when Rec#rec_label.bool -> + From ! {ok,Message}, + do_receive_label(Rec) + end. + +read_size_file_version(_Config) -> + ok = do_read_size_file_version({ok,<<42>>}), + {ok,7777} = do_read_size_file_version({ok,<<7777:32>>}), + ok. + +do_read_size_file_version(E) -> + case E of + {ok,<<Version>>} when Version =:= 42 -> + ok; + {ok,<<MaxFiles:32>>} -> + {ok,MaxFiles} + end. + %% The identity function. id(I) -> I. diff --git a/lib/compiler/test/beam_validator_SUITE.erl b/lib/compiler/test/beam_validator_SUITE.erl index c23514b36b..63a13281a8 100644 --- a/lib/compiler/test/beam_validator_SUITE.erl +++ b/lib/compiler/test/beam_validator_SUITE.erl @@ -33,8 +33,8 @@ state_after_fault_in_catch/1,no_exception_in_catch/1, undef_label/1,illegal_instruction/1,failing_gc_guard_bif/1, map_field_lists/1,cover_bin_opt/1, - val_dsetel/1]). - + val_dsetel/1,bad_tuples/1]). + -include_lib("common_test/include/ct.hrl"). init_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> @@ -61,7 +61,8 @@ groups() -> freg_state,bad_bin_match,bad_dsetel, state_after_fault_in_catch,no_exception_in_catch, undef_label,illegal_instruction,failing_gc_guard_bif, - map_field_lists,cover_bin_opt,val_dsetel]}]. + map_field_lists,cover_bin_opt,val_dsetel, + bad_tuples]}]. init_per_suite(Config) -> Config. @@ -421,9 +422,9 @@ try_bin_opt(Mod) -> try do_bin_opt(Mod) catch - Class:Error -> + Class:Error:Stk -> io:format("~p: ~p ~p\n~p\n", - [Mod,Class,Error,erlang:get_stacktrace()]), + [Mod,Class,Error,Stk]), error end. @@ -509,6 +510,19 @@ destroy_reg({Tag,N}) -> {y,N+1} end. +bad_tuples(Config) -> + Errors = do_val(bad_tuples, Config), + [{{bad_tuples,heap_overflow,1}, + {{put,{x,0}},8,{heap_overflow,{left,0},{wanted,1}}}}, + {{bad_tuples,long,2}, + {{put,{atom,too_long}},8,not_building_a_tuple}}, + {{bad_tuples,self_referential,1}, + {{put,{x,1}},7,{tuple_in_progress,{x,1}}}}, + {{bad_tuples,short,1}, + {{move,{x,1},{x,0}},7,{tuple_in_progress,{x,1}}}}] = Errors, + + ok. + %%%------------------------------------------------------------------------- transform_remove(Remove, Module) -> diff --git a/lib/compiler/test/beam_validator_SUITE_data/bad_tuples.S b/lib/compiler/test/beam_validator_SUITE_data/bad_tuples.S new file mode 100644 index 0000000000..7980241c37 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/bad_tuples.S @@ -0,0 +1,88 @@ +{module, bad_tuples}. %% version = 0 + +{exports, [{heap_overflow,1}, + {long,2}, + {module_info,0}, + {module_info,1}, + {self_referential,1}, + {short,1}]}. + +{attributes, []}. + +{labels, 13}. + + +{function, short, 1, 2}. + {label,1}. + {line,[{location,"bad_tuples.erl",4}]}. + {func_info,{atom,bad_tuples},{atom,short},1}. + {label,2}. + {test_heap,3,1}. + {put_tuple,2,{x,1}}. + {put,{atom,ok}}. + {move,{x,1},{x,0}}. + return. + + +{function, long, 2, 4}. + {label,3}. + {line,[{location,"bad_tuples.erl",7}]}. + {func_info,{atom,bad_tuples},{atom,long},2}. + {label,4}. + {test_heap,6,2}. + {put_tuple,2,{x,2}}. + {put,{x,0}}. + {put,{x,1}}. + {put,{atom,too_long}}. + {put_tuple,2,{x,0}}. + {put,{atom,ok}}. + {put,{x,2}}. + return. + + +{function, heap_overflow, 1, 6}. + {label,5}. + {line,[{location,"bad_tuples.erl",10}]}. + {func_info,{atom,bad_tuples},{atom,heap_overflow},1}. + {label,6}. + {test_heap,3,1}. + {put_tuple,2,{x,1}}. + {put,{atom,ok}}. + {put,{x,0}}. + {put,{x,0}}. + {move,{x,1},{x,0}}. + return. + + +{function, self_referential, 1, 8}. + {label,7}. + {line,[{location,"bad_tuples.erl",13}]}. + {func_info,{atom,bad_tuples},{atom,self_referential},1}. + {label,8}. + {test_heap,3,1}. + {put_tuple,2,{x,1}}. + {put,{atom,ok}}. + {put,{x,1}}. + {move,{x,1},{x,0}}. + return. + + +{function, module_info, 0, 10}. + {label,9}. + {line,[]}. + {func_info,{atom,bad_tuples},{atom,module_info},0}. + {label,10}. + {move,{atom,bad_tuples},{x,0}}. + {line,[]}. + {call_ext_only,1,{extfunc,erlang,get_module_info,1}}. + + +{function, module_info, 1, 12}. + {label,11}. + {line,[]}. + {func_info,{atom,bad_tuples},{atom,module_info},1}. + {label,12}. + {move,{x,0},{x,1}}. + {move,{atom,bad_tuples},{x,0}}. + {line,[]}. + {call_ext_only,2,{extfunc,erlang,get_module_info,2}}. diff --git a/lib/compiler/test/bs_match_SUITE.erl b/lib/compiler/test/bs_match_SUITE.erl index ad48d4c0b7..235956a714 100644 --- a/lib/compiler/test/bs_match_SUITE.erl +++ b/lib/compiler/test/bs_match_SUITE.erl @@ -39,7 +39,8 @@ match_string_opt/1,select_on_integer/1, map_and_binary/1,unsafe_branch_caching/1, bad_literals/1,good_literals/1,constant_propagation/1, - parse_xml/1,get_payload/1,escape/1,num_slots_different/1]). + parse_xml/1,get_payload/1,escape/1,num_slots_different/1, + beam_bsm/1,guard/1,is_ascii/1,non_opt_eq/1]). -export([coverage_id/1,coverage_external_ignore/2]). @@ -71,7 +72,8 @@ groups() -> match_string_opt,select_on_integer, map_and_binary,unsafe_branch_caching, bad_literals,good_literals,constant_propagation,parse_xml, - get_payload,escape,num_slots_different]}]. + get_payload,escape,num_slots_different, + beam_bsm,guard,is_ascii,non_opt_eq]}]. init_per_suite(Config) -> @@ -676,6 +678,10 @@ coverage(Config) when is_list(Config) -> <<>> = coverage_per_key(<<4:32>>), <<$a,$b,$c>> = coverage_per_key(<<7:32,"abc">>), + binary = coverage_bitstring(<<>>), + binary = coverage_bitstring(<<7>>), + bitstring = coverage_bitstring(<<7:4>>), + other = coverage_bitstring([a]), ok. coverage_fold(Fun, Acc, <<H,T/binary>>) -> @@ -766,6 +772,10 @@ coverage_per_key(<<BinSize:32,Bin/binary>> = B) -> true = (byte_size(B) =:= BinSize), Bin. +coverage_bitstring(Bin) when is_binary(Bin) -> binary; +coverage_bitstring(<<_/bitstring>>) -> bitstring; +coverage_bitstring(_) -> other. + multiple_uses(Config) when is_list(Config) -> {344,62879,345,<<245,159,1,89>>} = multiple_uses_1(<<1,88,245,159,1,89>>), true = multiple_uses_2(<<0,0,197,18>>), @@ -799,7 +809,7 @@ multiple_uses_cmp(<<_:16>>, <<_:16>>) -> false. first_after(Data, Offset) -> case byte_size(Data) > Offset of false -> - {First, Rest} = {ok, ok}, + {_First, _Rest} = {ok, ok}, ok; true -> <<_:Offset/binary, Rest/binary>> = Data, @@ -1513,7 +1523,7 @@ is_next_char_whitespace(<<C/utf8,_/binary>>) -> {this_hdr = 17, ext_hdr_opts}). -get_payload(Config) -> +get_payload(_Config) -> <<3445:48>> = do_get_payload(#ext_header{ext_hdr_opts = <<3445:48>>}), {'EXIT',_} = (catch do_get_payload(#ext_header{})), ok. @@ -1572,6 +1582,101 @@ lgettext(<<"de">>, <<"navigation">>, <<"Results">>) -> lgettext(<<"de">>, <<"navigation">>, <<"Resources">>) -> {ok, <<"Ressourcen">>}. +%% Test more code in beam_bsm. +beam_bsm(_Config) -> + true = check_bitstring_list(<<1:1,0:1,1:1,1:1>>, [1,0,1,1]), + false = check_bitstring_list(<<1:1,0:1,1:1,1:1>>, [0]), + + true = bsm_validate_scheme(<<>>), + true = bsm_validate_scheme(<<5,10>>), + false = bsm_validate_scheme(<<5,10,11,12>>), + true = bsm_validate_scheme([]), + true = bsm_validate_scheme([5,10]), + false = bsm_validate_scheme([5,6,7]), + + <<1,2,3>> = bsm_must_save_and_not_save(<<1,2,3>>, []), + D = fun(N) -> 2*N end, + [2,4|<<3>>] = bsm_must_save_and_not_save(<<1,2,3>>, [D,D]), + + ok. + +check_bitstring_list(<<H:1,T1/bitstring>>, [H|T2]) -> + check_bitstring_list(T1, T2); +check_bitstring_list(<<>>, []) -> + true; +check_bitstring_list(_, _) -> + false. + +bsm_validate_scheme([]) -> true; +bsm_validate_scheme([H|T]) -> + case bsm_is_scheme(H) of + true -> bsm_validate_scheme(T); + false -> false + end; +bsm_validate_scheme(<<>>) -> true; +bsm_validate_scheme(<<H, Rest/binary>>) -> + case bsm_is_scheme(H) of + true -> bsm_validate_scheme(Rest); + false -> false + end. + +bsm_is_scheme(Int) -> + Int rem 5 =:= 0. + +%% NOT OPTIMIZED: different control paths use different positions in the binary +bsm_must_save_and_not_save(Bin, []) -> + Bin; +bsm_must_save_and_not_save(<<H,T/binary>>, [F|Fs]) -> + [F(H)|bsm_must_save_and_not_save(T, Fs)]; +bsm_must_save_and_not_save(<<>>, []) -> + []. + +guard(_Config) -> + _Tuple = id({a,b}), + ok = guard_1(<<1,2,3>>, {1,2,3}), + ok = guard_2(<<42>>, #{}), + ok. + +%% Cover handling of #k_put{} in v3_codegen:bsm_rename_ctx/4. +guard_1(<<A,B,C>>, Tuple) when Tuple =:= {A,B,C} -> + ok. + +%% Cover handling of #k_call{} in v3_codegen:bsm_rename_ctx/4. +guard_2(<<_>>, Healing) when Healing#{[] => Healing} =:= #{[] => #{}} -> + ok. + +is_ascii(_Config) -> + true = do_is_ascii(<<>>), + true = do_is_ascii(<<"string">>), + false = do_is_ascii(<<1024/utf8>>), + {'EXIT',{function_clause,_}} = (catch do_is_ascii(<<$A,0:3>>)), + {'EXIT',{function_clause,_}} = (catch do_is_ascii(<<16#80,0:3>>)), + ok. + +do_is_ascii(<<>>) -> + true; +do_is_ascii(<<C,_/binary>>) when C >= 16#80 -> + %% This clause must fail to match if the size of the argument in + %% bits is not divisible by 8. Beware of unsafe optimizations. + false; +do_is_ascii(<<_, T/binary>>) -> + do_is_ascii(T). + +non_opt_eq(_Config) -> + true = non_opt_eq([], <<>>), + true = non_opt_eq([$a], <<$a>>), + false = non_opt_eq([$a], <<$b>>), + ok. + +%% An example from the Efficiency Guide. It used to be not optimized, +%% but now it can be optimized. + +non_opt_eq([H|T1], <<H,T2/binary>>) -> + non_opt_eq(T1, T2); +non_opt_eq([_|_], <<_,_/binary>>) -> + false; +non_opt_eq([], <<>>) -> + true. check(F, R) -> R = F(). diff --git a/lib/compiler/test/compile_SUITE.erl b/lib/compiler/test/compile_SUITE.erl index 25983c6012..eee5bc733f 100644 --- a/lib/compiler/test/compile_SUITE.erl +++ b/lib/compiler/test/compile_SUITE.erl @@ -120,9 +120,19 @@ file_1(Config) when is_list(Config) -> true = exists(Target), passed = run(Target, test, []), + %% Test option 'deterministic' as a compiler attribute. + Det = deterministic_module, + {DetPath, DetTarget} = get_files(Config, Det, "det_target"), + {ok,Det,DetCode} = compile:file(DetPath, [binary]), + {module,Det} = code:load_binary(Det, "", DetCode), + [{version,_}] = Det:module_info(compile), + true = code:delete(Det), + false = code:purge(Det), + %% Cleanup. ok = file:delete(Target), ok = file:del_dir(filename:dirname(Target)), + ok = file:del_dir(filename:dirname(DetTarget)), %% There should not be any messages in the messages. receive @@ -375,7 +385,6 @@ do_file_listings(DataDir, PrivDir, [File|Files]) -> do_listing(Simple, TargetDir, dcbsm, ".core_bsm"), do_listing(Simple, TargetDir, dsetel, ".dsetel"), do_listing(Simple, TargetDir, dkern, ".kernel"), - do_listing(Simple, TargetDir, dlife, ".life"), do_listing(Simple, TargetDir, dcg, ".codegen"), do_listing(Simple, TargetDir, dblk, ".block"), do_listing(Simple, TargetDir, dexcept, ".except"), @@ -399,6 +408,7 @@ do_file_listings(DataDir, PrivDir, [File|Files]) -> ok = file:delete(filename:join(Listings, File ++ ".core")), do_listing(Simple, TargetDir, to_core, ".core"), do_listing(Simple, TargetDir, to_kernel, ".kernel"), + do_listing(Simple, TargetDir, to_dis, ".dis"), %% Final clean up. lists:foreach(fun(F) -> ok = file:delete(F) end, @@ -414,6 +424,7 @@ listings_big(Config) when is_list(Config) -> do_listing(Big, TargetDir, 'E'), do_listing(Big, TargetDir, 'P'), do_listing(Big, TargetDir, dkern, ".kernel"), + do_listing(Big, TargetDir, to_dis, ".dis"), TargetNoext = filename:rootname(Target, code:objfile_extension()), {ok,big} = compile:file(TargetNoext, [from_asm,{outdir,TargetDir}]), @@ -489,9 +500,8 @@ do_kernel_listing({M,A}) -> io:format("*** compilation failure '~p' for module ~s\n", [Error,M]), error; - Class:Error -> - io:format("~p: ~p ~p\n~p\n", - [M,Class,Error,erlang:get_stacktrace()]), + Class:Error:Stk -> + io:format("~p: ~p ~p\n~p\n", [M,Class,Error,Stk]), error end. @@ -891,9 +901,8 @@ do_core_pp({M,A}, Outdir) -> io:format("*** compilation failure '~p' for module ~s\n", [Error,M]), error; - Class:Error -> - io:format("~p: ~p ~p\n~p\n", - [M,Class,Error,erlang:get_stacktrace()]), + Class:Error:Stk -> + io:format("~p: ~p ~p\n~p\n", [M,Class,Error,Stk]), error end. @@ -950,9 +959,8 @@ do_core_roundtrip(Beam, Outdir) -> io:format("*** compilation failure '~p' for file ~s\n", [Error,Beam]), error; - Class:Error -> - io:format("~p: ~p ~p\n~p\n", - [Beam,Class,Error,erlang:get_stacktrace()]), + Class:Error:Stk -> + io:format("~p: ~p ~p\n~p\n", [Beam,Class,Error,Stk]), error end. @@ -1137,9 +1145,8 @@ do_asm(Beam, Outdir) -> [Other,AsmFile]), error end - catch Class:Error -> - io:format("~p: ~p ~p\n~p\n", - [M,Class,Error,erlang:get_stacktrace()]), + catch Class:Error:Stk -> + io:format("~p: ~p ~p\n~p\n", [M,Class,Error,Stk]), error end. @@ -1156,9 +1163,8 @@ do_opt_guards(Beam) -> try {ok,M,Asm} = compile:forms(A, ['S']), do_opt_guards_mod(Asm) - catch Class:Error -> - io:format("~p: ~p ~p\n~p\n", - [M,Class,Error,erlang:get_stacktrace()]), + catch Class:Error:Stk -> + io:format("~p: ~p ~p\n~p\n", [M,Class,Error,Stk]), error end. @@ -1319,10 +1325,13 @@ do_warnings_2([], Next, F) -> %% pre-loads the modules that are used by a typical compilation. pre_load_check(Config) -> - case test_server:is_cover() of - true -> + case {test_server:is_cover(),code:module_info(native)} of + {true,_} -> {skip,"Cover is running"}; - false -> + {false,true} -> + %% Tracing won't work. + {skip,"'code' is native-compiled"}; + {false,false} -> try do_pre_load_check(Config) after @@ -1446,19 +1455,21 @@ env_compiler_options(_Config) -> bc_options(Config) -> DataDir = proplists:get_value(data_dir, Config), - 101 = highest_opcode(DataDir, small_float, [no_line_info]), + 101 = highest_opcode(DataDir, small_float, [no_get_hd_tl,no_line_info]), 103 = highest_opcode(DataDir, big, - [no_record_opt,no_line_info,no_stack_trimming]), + [no_get_hd_tl,no_record_opt, + no_line_info,no_stack_trimming]), - 125 = highest_opcode(DataDir, small_float, [no_line_info,no_float_opt]), + 125 = highest_opcode(DataDir, small_float, + [no_get_hd_tl,no_line_info,no_float_opt]), 132 = highest_opcode(DataDir, small, - [no_record_opt,no_float_opt,no_line_info]), + [no_get_hd_tl,no_record_opt,no_float_opt,no_line_info]), - 136 = highest_opcode(DataDir, big, [no_record_opt,no_line_info]), + 136 = highest_opcode(DataDir, big, [no_get_hd_tl,no_record_opt,no_line_info]), - 153 = highest_opcode(DataDir, big, [no_record_opt]), + 153 = highest_opcode(DataDir, big, [no_get_hd_tl,no_record_opt]), 153 = highest_opcode(DataDir, big, [r16]), 153 = highest_opcode(DataDir, big, [r17]), 153 = highest_opcode(DataDir, big, [r18]), @@ -1469,9 +1480,10 @@ bc_options(Config) -> 158 = highest_opcode(DataDir, small_maps, [r17]), 158 = highest_opcode(DataDir, small_maps, [r18]), 158 = highest_opcode(DataDir, small_maps, [r19]), + 158 = highest_opcode(DataDir, small_maps, [r20]), 158 = highest_opcode(DataDir, small_maps, []), - 159 = highest_opcode(DataDir, big, []), + 163 = highest_opcode(DataDir, big, []), ok. diff --git a/lib/compiler/test/compile_SUITE_data/big.erl b/lib/compiler/test/compile_SUITE_data/big.erl index 2e54ee8660..1db07755a1 100644 --- a/lib/compiler/test/compile_SUITE_data/big.erl +++ b/lib/compiler/test/compile_SUITE_data/big.erl @@ -741,3 +741,7 @@ snmp_access(suite) -> debug_support(suite) -> [ info, schema, schema, kill, lkill ]. +%% Cover translation of get_hd/2 to get_list/3 when option no_get_hd_tl +%% is given. +cover_get_hd([Hd|_]) -> + Hd. diff --git a/lib/compiler/test/compile_SUITE_data/deterministic_module.erl b/lib/compiler/test/compile_SUITE_data/deterministic_module.erl new file mode 100644 index 0000000000..5e0e29c25e --- /dev/null +++ b/lib/compiler/test/compile_SUITE_data/deterministic_module.erl @@ -0,0 +1,21 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. 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(deterministic_module). +-compile([deterministic]). diff --git a/lib/compiler/test/core_fold_SUITE.erl b/lib/compiler/test/core_fold_SUITE.erl index 262967d03d..4fd1f84569 100644 --- a/lib/compiler/test/core_fold_SUITE.erl +++ b/lib/compiler/test/core_fold_SUITE.erl @@ -27,7 +27,7 @@ multiple_aliases/1,redundant_boolean_clauses/1, mixed_matching_clauses/1,unnecessary_building/1, no_no_file/1,configuration/1,supplies/1, - redundant_stack_frame/1]). + redundant_stack_frame/1,export_from_case/1]). -export([foo/0,foo/1,foo/2,foo/3]). @@ -47,7 +47,7 @@ groups() -> multiple_aliases,redundant_boolean_clauses, mixed_matching_clauses,unnecessary_building, no_no_file,configuration,supplies, - redundant_stack_frame]}]. + redundant_stack_frame,export_from_case]}]. init_per_suite(Config) -> @@ -551,4 +551,38 @@ do_redundant_stack_frame(Map) -> end, {X, Y}. +%% Cover some clauses in sys_core_fold:remove_first_value/2. + +-record(export_from_case, {val}). + +export_from_case(_Config) -> + a = export_from_case_1(true), + b = export_from_case_1(false), + + R = #export_from_case{val=0}, + {ok,R} = export_from_case_2(false, R), + {ok,#export_from_case{val=42}} = export_from_case_2(true, R), + + ok. + +export_from_case_1(Bool) -> + case Bool of + true -> + id(42), + Result = a; + false -> + Result = b + end, + id(Result). + +export_from_case_2(Bool, Rec) -> + case Bool of + false -> + Result = Rec; + true -> + Result = Rec#export_from_case{val=42} + end, + {ok,Result}. + + id(I) -> I. diff --git a/lib/compiler/test/guard_SUITE.erl b/lib/compiler/test/guard_SUITE.erl index d96cfdb7ac..0d6f8c6f98 100644 --- a/lib/compiler/test/guard_SUITE.erl +++ b/lib/compiler/test/guard_SUITE.erl @@ -35,7 +35,8 @@ basic_andalso_orelse/1,traverse_dcd/1, check_qlc_hrl/1,andalso_semi/1,t_tuple_size/1,binary_part/1, bad_constants/1,bad_guards/1, - guard_in_catch/1,beam_bool_SUITE/1]). + guard_in_catch/1,beam_bool_SUITE/1, + cover_beam_dead/1]). suite() -> [{ct_hooks,[ts_install_cth]}]. @@ -54,7 +55,8 @@ groups() -> rel_ops,rel_op_combinations, literal_type_tests,basic_andalso_orelse,traverse_dcd, check_qlc_hrl,andalso_semi,t_tuple_size,binary_part, - bad_constants,bad_guards,guard_in_catch,beam_bool_SUITE]}]. + bad_constants,bad_guards,guard_in_catch,beam_bool_SUITE, + cover_beam_dead]}]. init_per_suite(Config) -> Config. @@ -1619,7 +1621,9 @@ type_tests() -> is_reference, is_port, is_binary, - is_function]. + is_bitstring, + is_function, + is_map]. basic_andalso_orelse(Config) when is_list(Config) -> T = id({type,integers,23,42}), @@ -2202,7 +2206,31 @@ maps() -> evidence(#{0 := Charge}) when 0; #{[] => Charge} == #{[] => 42} -> ok. +cover_beam_dead(_Config) -> + Mod = ?FUNCTION_NAME, + Attr = [], + Fs = [{function,test,1,2, + [{label,1}, + {line,[]}, + {func_info,{atom,Mod},{atom,test},1}, + {label,2}, + %% Cover beam_dead:turn_op/1 using swapped operand order. + {test,is_ne_exact,{f,3},[{integer,1},{x,0}]}, + {test,is_eq_exact,{f,1},[{atom,a},{x,0}]}, + {label,3}, + {move,{atom,ok},{x,0}}, + return]}], + Exp = [{test,1}], + Asm = {Mod,Exp,Attr,Fs,3}, + {ok,Mod,Beam} = compile:forms(Asm, [from_asm,binary,report]), + {module,Mod} = code:load_binary(Mod, Mod, Beam), + ok = Mod:test(1), + ok = Mod:test(a), + {'EXIT',_} = (catch Mod:test(other)), + true = code:delete(Mod), + _ = code:purge(Mod), + ok. %% Call this function to turn off constant propagation. id(I) -> I. diff --git a/lib/compiler/test/map_SUITE.erl b/lib/compiler/test/map_SUITE.erl index 5e90b79aa2..f15917e3cb 100644 --- a/lib/compiler/test/map_SUITE.erl +++ b/lib/compiler/test/map_SUITE.erl @@ -695,8 +695,28 @@ t_is_map(Config) when is_list(Config) -> if is_map(#{b=>1}) -> ok end, if not is_map([1,2,3]) -> ok end, if not is_map(x) -> ok end, + + ok = do_t_is_map(map, #{}), + error = do_t_is_map(map, {a,b,c}), + ok = do_t_is_map(number, 42), + ok = do_t_is_map(number, 42.0), + error = do_t_is_map(number, {a,b,c}), ok. +do_t_is_map(What, X) -> + B = case What of + map -> + %% Cover conversion of is_map/1 BIF to test instruction + %% in beam_utils:bif_to_test/3. + is_map(X); + number -> + is_number(X) + end, + case B of + true -> ok; + false -> error + end. + % test map updates without matching t_update_literals(Config) when is_list(Config) -> Map = #{x=>1,y=>2,z=>3,q=>4}, diff --git a/lib/compiler/test/match_SUITE.erl b/lib/compiler/test/match_SUITE.erl index c31695be24..4b26a8dcdc 100644 --- a/lib/compiler/test/match_SUITE.erl +++ b/lib/compiler/test/match_SUITE.erl @@ -24,7 +24,8 @@ pmatch/1,mixed/1,aliases/1,non_matching_aliases/1, match_in_call/1,untuplify/1,shortcut_boolean/1,letify_guard/1, selectify/1,deselectify/1,underscore/1,match_map/1,map_vars_used/1, - coverage/1,grab_bag/1,literal_binary/1]). + coverage/1,grab_bag/1,literal_binary/1, + unary_op/1]). -include_lib("common_test/include/ct.hrl"). @@ -40,7 +41,7 @@ groups() -> match_in_call,untuplify, shortcut_boolean,letify_guard,selectify,deselectify, underscore,match_map,map_vars_used,coverage, - grab_bag,literal_binary]}]. + grab_bag,literal_binary,unary_op]}]. init_per_suite(Config) -> @@ -617,6 +618,10 @@ grab_bag(_Config) -> {bad,16#555555555555555555555555555555555555555555555555555}], ok = grab_bag_remove_failure(L, unit, 0), + {42,<<43,44>>} = grab_bag_single_valued(<<42,43,44>>), + empty_list = grab_bag_single_valued([]), + empty_tuple = grab_bag_single_valued({}), + ok. grab_bag_remove_failure([], _Unit, _MaxFailure) -> @@ -634,6 +639,12 @@ grab_bag_remove_failure([{stretch,_,Mi}=Stretch | Specs], Unit, _MaxFailure) -> ok end. +%% Cover a line v3_kernel that places binary matching first. +grab_bag_single_valued(<<H,T/bytes>>) -> {H,T}; +grab_bag_single_valued([]) -> empty_list; +grab_bag_single_valued({}) -> empty_tuple. + + %% Regression in 19.0, reported by Alexei Sholik literal_binary(_Config) -> 3 = literal_binary_match(bar, <<"y">>), @@ -652,5 +663,74 @@ literal_binary_match(_, <<"x">>) -> 2; literal_binary_match(_, <<"y">>) -> 3; literal_binary_match(_, _) -> fail. +unary_op(Config) -> + %% ERL-514. This test case only verifies that the code + %% calculates the correct result, not that the generated + %% code is optimial. + + {non_associative,30} = unary_op_1('&'), + {non_associative,300} = unary_op_1('^'), + {non_associative,300} = unary_op_1('not'), + {non_associative,300} = unary_op_1('+'), + {non_associative,300} = unary_op_1('-'), + {non_associative,300} = unary_op_1('~~~'), + {non_associative,300} = unary_op_1('!'), + {non_associative,320} = unary_op_1('@'), + + error = unary_op_1(Config), + error = unary_op_1(abc), + error = unary_op_1(42), + + ok. + +unary_op_1(Vop@1) -> + %% If all optimizations are working as they should, there should + %% be no stack frame and all '=:=' tests should be coalesced into + %% a single select_val instruction. + + case Vop@1 =:= '&' of + true -> + {non_associative,30}; + false -> + case + case Vop@1 =:= '^' of + true -> + true; + false -> + case Vop@1 =:= 'not' of + true -> + true; + false -> + case Vop@1 =:= '+' of + true -> + true; + false -> + case Vop@1 =:= '-' of + true -> + true; + false -> + case Vop@1 =:= '~~~' of + true -> + true; + false -> + Vop@1 =:= '!' + end + end + end + end + end + of + true -> + {non_associative,300}; + false -> + case Vop@1 =:= '@' of + true -> + {non_associative,320}; + false -> + error + end + end + end. + id(I) -> I. diff --git a/lib/compiler/test/misc_SUITE.erl b/lib/compiler/test/misc_SUITE.erl index ea4aaf40a9..4e39f4663e 100644 --- a/lib/compiler/test/misc_SUITE.erl +++ b/lib/compiler/test/misc_SUITE.erl @@ -171,7 +171,7 @@ silly_coverage(Config) when is_list(Config) -> expect_error(fun() -> sys_core_dsetel:module(BadCoreErlang, []) end), expect_error(fun() -> v3_kernel:module(BadCoreErlang, []) end), - %% v3_life + %% v3_codegen BadKernel = {k_mdef,[],?MODULE, [{foo,0}], [], @@ -179,11 +179,7 @@ silly_coverage(Config) when is_list(Config) -> {k,[],[],[]}, f,0,[], seriously_bad_body}]}, - expect_error(fun() -> v3_life:module(BadKernel, []) end), - - %% v3_codegen - CodegenInput = {?MODULE,[{foo,0}],[],[{function,foo,0,[a|b],a,b,[]}]}, - expect_error(fun() -> v3_codegen:module(CodegenInput, []) end), + expect_error(fun() -> v3_codegen:module(BadKernel, []) end), %% beam_a BeamAInput = {?MODULE,[{foo,0}],[], @@ -322,8 +318,7 @@ expect_error(Fun) -> io:format("~p", [Any]), ct:fail(call_was_supposed_to_fail) catch - Class:Reason -> - Stk = erlang:get_stacktrace(), + Class:Reason:Stk -> io:format("~p:~p\n~p\n", [Class,Reason,Stk]), case {Class,Reason} of {error,undef} -> @@ -364,9 +359,7 @@ integer_encoding_1(Config) -> io:put_chars(Src, "t(Last) ->[\n"), io:put_chars(Data, "[\n"), - do_integer_encoding(-(id(1) bsl 10000), Src, Data), - do_integer_encoding(id(1) bsl 10000, Src, Data), - do_integer_encoding(1024, 0, Src, Data), + do_integer_encoding(137, 0, Src, Data), _ = [begin B = 1 bsl I, do_integer_encoding(-B-1, Src, Data), @@ -375,7 +368,7 @@ integer_encoding_1(Config) -> do_integer_encoding(B-1, Src, Data), do_integer_encoding(B, Src, Data), do_integer_encoding(B+1, Src, Data) - end || I <- lists:seq(1, 128)], + end || I <- lists:seq(1, 130)], io:put_chars(Src, "Last].\n\n"), ok = file:close(Src), io:put_chars(Data, "0].\n\n"), @@ -389,8 +382,6 @@ integer_encoding_1(Config) -> %% Compare lists. List = Mod:t(0), {ok,[List]} = file:consult(DataFile), - OneBsl10000 = id(1) bsl 10000, - [-(1 bsl 10000),OneBsl10000|_] = List, %% Cleanup. file:delete(SrcFile), @@ -409,7 +400,3 @@ do_integer_encoding(I, Src, Data) -> Str = integer_to_list(I), io:put_chars(Src, [Str,",\n"]), io:put_chars(Data, [Str,",\n"]). - - -id(I) -> I. - diff --git a/lib/compiler/test/receive_SUITE.erl b/lib/compiler/test/receive_SUITE.erl index 8304672558..5e386790c0 100644 --- a/lib/compiler/test/receive_SUITE.erl +++ b/lib/compiler/test/receive_SUITE.erl @@ -222,9 +222,8 @@ do_ref_opt(Source, PrivDir) -> collect_recv_opt_instrs(Code) end, ok - catch Class:Error -> - io:format("~s: ~p ~p\n~p\n", - [Source,Class,Error,erlang:get_stacktrace()]), + catch Class:Error:Stk -> + io:format("~s: ~p ~p\n~p\n", [Source,Class,Error,Stk]), error end. @@ -265,6 +264,10 @@ export(Config) when is_list(Config) -> self() ! {result,Ref,42}, 42 = export_1(Ref), {error,timeout} = export_1(Ref), + + self() ! {result,Ref}, + {ok,Ref} = export_2(), + ok. export_1(Reference) -> @@ -281,6 +284,10 @@ export_1(Reference) -> id({build,self()}), Result. +export_2() -> + receive {result,Result} -> ok end, + {ok,Result}. + wait(Config) when is_list(Config) -> self() ! <<42>>, <<42>> = wait_1(r, 1, 2), diff --git a/lib/compiler/test/trycatch_SUITE.erl b/lib/compiler/test/trycatch_SUITE.erl index 42dbf7d5f0..d5a1dc642f 100644 --- a/lib/compiler/test/trycatch_SUITE.erl +++ b/lib/compiler/test/trycatch_SUITE.erl @@ -26,7 +26,8 @@ nested_of/1,nested_catch/1,nested_after/1, nested_horrid/1,last_call_optimization/1,bool/1, plain_catch_coverage/1,andalso_orelse/1,get_in_try/1, - hockey/1,handle_info/1,catch_in_catch/1,grab_bag/1]). + hockey/1,handle_info/1,catch_in_catch/1,grab_bag/1, + stacktrace/1,nested_stacktrace/1,raise/1]). -include_lib("common_test/include/ct.hrl"). @@ -42,7 +43,8 @@ groups() -> after_oops,eclectic,rethrow,nested_of,nested_catch, nested_after,nested_horrid,last_call_optimization, bool,plain_catch_coverage,andalso_orelse,get_in_try, - hockey,handle_info,catch_in_catch,grab_bag]}]. + hockey,handle_info,catch_in_catch,grab_bag, + stacktrace,nested_stacktrace,raise]}]. init_per_suite(Config) -> @@ -115,6 +117,16 @@ basic(Conf) when is_list(Conf) -> catch nisse -> erro end, + %% Unmatchable clauses. + try + throw(thrown) + catch + {a,b}={a,b,c} -> %Intentionally no match. + ok; + thrown -> + ok + end, + ok. after_call() -> @@ -1039,5 +1051,217 @@ grab_bag(_Config) -> ok. +stacktrace(_Config) -> + V = [make_ref()|self()], + case ?MODULE:module_info(native) of + false -> + {value2,{caught1,badarg,[{erlang,abs,[V],_}|_]}} = + stacktrace_1({'abs',V}, error, {value,V}), + {caught2,{error,badarith},[{erlang,'+',[0,a],_}, + {?MODULE,my_add,2,_}|_]} = + stacktrace_1({'div',{1,0}}, error, {'add',{0,a}}); + true -> + {value2,{caught1,badarg,[{?MODULE,my_abs,1,_}|_]}} = + stacktrace_1({'abs',V}, error, {value,V}), + {caught2,{error,badarith},[{?MODULE,my_add,2,_}|_]} = + stacktrace_1({'div',{1,0}}, error, {'add',{0,a}}) + end, + {caught2,{error,{try_clause,V}},[{?MODULE,stacktrace_1,3,_}|_]} = + stacktrace_1({value,V}, error, {value,V}), + {caught2,{throw,V},[{?MODULE,foo,1,_}|_]} = + stacktrace_1({value,V}, error, {throw,V}), + + try + stacktrace_2() + catch + error:{badmatch,_}:Stk2 -> + [{?MODULE,stacktrace_2,0,_}, + {?MODULE,stacktrace,1,_}|_] = Stk2, + Stk2 = erlang:get_stacktrace(), + ok + end, + + try + stacktrace_3(a, b) + catch + error:function_clause:Stk3 -> + Stk3 = erlang:get_stacktrace(), + case lists:module_info(native) of + false -> + [{lists,prefix,[a,b],_}|_] = Stk3; + true -> + [{lists,prefix,2,_}|_] = Stk3 + end + end, + + try + throw(x) + catch + throw:x:IntentionallyUnused -> + ok + end. + +stacktrace_1(X, C1, Y) -> + try try foo(X) of + C1 -> value1 + catch + C1:D1:Stk1 -> + Stk1 = erlang:get_stacktrace(), + {caught1,D1,Stk1} + after + foo(Y) + end of + V2 -> {value2,V2} + catch + C2:D2:Stk2 -> {caught2,{C2,D2},Stk2=erlang:get_stacktrace()} + end. + +stacktrace_2() -> + ok = erlang:process_info(self(), current_function), + ok. + +stacktrace_3(A, B) -> + {ok,lists:prefix(A, B)}. + +nested_stacktrace(_Config) -> + V = [{make_ref()}|[self()]], + value1 = nested_stacktrace_1({{value,{V,x1}},void,{V,x1}}, + {void,void,void}), + case ?MODULE:module_info(native) of + false -> + {caught1, + [{erlang,'+',[V,x1],_},{?MODULE,my_add,2,_}|_], + value2} = + nested_stacktrace_1({{'add',{V,x1}},error,badarith}, + {{value,{V,x2}},void,{V,x2}}), + {caught1, + [{erlang,'+',[V,x1],_},{?MODULE,my_add,2,_}|_], + {caught2,[{erlang,abs,[V],_}|_]}} = + nested_stacktrace_1({{'add',{V,x1}},error,badarith}, + {{'abs',V},error,badarg}); + true -> + {caught1, + [{?MODULE,my_add,2,_}|_], + value2} = + nested_stacktrace_1({{'add',{V,x1}},error,badarith}, + {{value,{V,x2}},void,{V,x2}}), + {caught1, + [{?MODULE,my_add,2,_}|_], + {caught2,[{?MODULE,my_abs,1,_}|_]}} = + nested_stacktrace_1({{'add',{V,x1}},error,badarith}, + {{'abs',V},error,badarg}) + end, + ok. + +nested_stacktrace_1({X1,C1,V1}, {X2,C2,V2}) -> + try foo(X1) of + V1 -> value1 + catch + C1:V1:S1 -> + S1 = erlang:get_stacktrace(), + T2 = try foo(X2) of + V2 -> value2 + catch + C2:V2:S2 -> + S2 = erlang:get_stacktrace(), + {caught2,S2} + end, + {caught1,S1,T2} + end. + +raise(_Config) -> + test_raise(fun() -> exit({exit,tuple}) end), + test_raise(fun() -> abs(id(x)) end), + test_raise(fun() -> throw({was,thrown}) end), + + badarg = bad_raise(fun() -> abs(id(x)) end), + + ok. + +bad_raise(Expr) -> + try + Expr() + catch + _:E:Stk -> + erlang:raise(bad_class, E, Stk) + end. + +test_raise(Expr) -> + test_raise_1(Expr), + test_raise_2(Expr), + test_raise_3(Expr). + +test_raise_1(Expr) -> + erase(exception), + try + do_test_raise_1(Expr) + catch + C:E:Stk -> + {C,E,Stk} = erase(exception) + end. + +do_test_raise_1(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here the stacktrace must be built. + put(exception, {C,E,Stk}), + erlang:raise(C, E, Stk) + end. + +test_raise_2(Expr) -> + erase(exception), + try + do_test_raise_2(Expr) + catch + C:E:Stk -> + {C,E} = erase(exception), + try + Expr() + catch + _:_:S -> + [StkTop|_] = S, + [StkTop|_] = Stk + end + end. + +do_test_raise_2(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here it is possible to replace erlang:raise/3 with + %% the raw_raise/3 instruction since the stacktrace is + %% not actually used. + put(exception, {C,E}), + erlang:raise(C, E, Stk) + end. + +test_raise_3(Expr) -> + try + do_test_raise_3(Expr) + catch + exit:{exception,C,E}:Stk -> + try + Expr() + catch + C:E:S -> + [StkTop|_] = S, + [StkTop|_] = Stk + end + end. + +do_test_raise_3(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here it is possible to replace erlang:raise/3 with + %% the raw_raise/3 instruction since the stacktrace is + %% not actually used. + erlang:raise(exit, {exception,C,E}, Stk) + end. + id(I) -> I. diff --git a/lib/compiler/test/z_SUITE.erl b/lib/compiler/test/z_SUITE.erl index d864184f4c..cd95d0e733 100644 --- a/lib/compiler/test/z_SUITE.erl +++ b/lib/compiler/test/z_SUITE.erl @@ -54,8 +54,7 @@ do_loaded([{M,_}|Ms], E0) -> _ = M:module_info(functions), E0 catch - C:Error -> - Stk = erlang:get_stacktrace(), + C:Error:Stk -> io:format("~p:~p\n~p\n", [C,Error,Stk]), E0 + 1 end, diff --git a/lib/compiler/vsn.mk b/lib/compiler/vsn.mk index 435a57aac2..082786c7d8 100644 --- a/lib/compiler/vsn.mk +++ b/lib/compiler/vsn.mk @@ -1 +1 @@ -COMPILER_VSN = 7.1.3 +COMPILER_VSN = 7.1.4 diff --git a/lib/cosEvent/doc/src/notes.xml b/lib/cosEvent/doc/src/notes.xml index fe94cb64d3..ba0b0d88db 100644 --- a/lib/cosEvent/doc/src/notes.xml +++ b/lib/cosEvent/doc/src/notes.xml @@ -33,7 +33,22 @@ <file>notes.xml</file> </header> - <section><title>cosEvent 2.2.1</title> + <section><title>cosEvent 2.2.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + +<section><title>cosEvent 2.2.1</title> <section><title>Improvements and New Features</title> <list> diff --git a/lib/cosEvent/vsn.mk b/lib/cosEvent/vsn.mk index c39bed9fe4..578950294a 100644 --- a/lib/cosEvent/vsn.mk +++ b/lib/cosEvent/vsn.mk @@ -1,2 +1,2 @@ -COSEVENT_VSN = 2.2.1 +COSEVENT_VSN = 2.2.2 diff --git a/lib/cosEventDomain/doc/src/notes.xml b/lib/cosEventDomain/doc/src/notes.xml index 5e5bb2c33e..bd0a119ad2 100644 --- a/lib/cosEventDomain/doc/src/notes.xml +++ b/lib/cosEventDomain/doc/src/notes.xml @@ -32,7 +32,22 @@ <file>notes.xml</file> </header> - <section><title>cosEventDomain 1.2.1</title> + <section><title>cosEventDomain 1.2.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + +<section><title>cosEventDomain 1.2.1</title> <section><title>Improvements and New Features</title> <list> diff --git a/lib/cosEventDomain/vsn.mk b/lib/cosEventDomain/vsn.mk index 4e10d6ac60..0c063a00f9 100644 --- a/lib/cosEventDomain/vsn.mk +++ b/lib/cosEventDomain/vsn.mk @@ -1,2 +1,2 @@ -COSEVENTDOMAIN_VSN = 1.2.1 +COSEVENTDOMAIN_VSN = 1.2.2 diff --git a/lib/cosFileTransfer/doc/src/notes.xml b/lib/cosFileTransfer/doc/src/notes.xml index 58ab087014..e0b4bdf64b 100644 --- a/lib/cosFileTransfer/doc/src/notes.xml +++ b/lib/cosFileTransfer/doc/src/notes.xml @@ -31,7 +31,22 @@ <file>notes.xml</file> </header> - <section><title>cosFileTransfer 1.2.1</title> + <section><title>cosFileTransfer 1.2.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + +<section><title>cosFileTransfer 1.2.1</title> <section><title>Improvements and New Features</title> <list> diff --git a/lib/cosFileTransfer/vsn.mk b/lib/cosFileTransfer/vsn.mk index e271c05242..561f11fbb2 100644 --- a/lib/cosFileTransfer/vsn.mk +++ b/lib/cosFileTransfer/vsn.mk @@ -1 +1 @@ -COSFILETRANSFER_VSN = 1.2.1 +COSFILETRANSFER_VSN = 1.2.2 diff --git a/lib/cosNotification/doc/src/notes.xml b/lib/cosNotification/doc/src/notes.xml index 1237000153..bf0fc73548 100644 --- a/lib/cosNotification/doc/src/notes.xml +++ b/lib/cosNotification/doc/src/notes.xml @@ -32,7 +32,22 @@ <file>notes.xml</file> </header> - <section><title>cosNotification 1.2.2</title> + <section><title>cosNotification 1.2.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + +<section><title>cosNotification 1.2.2</title> <section><title>Improvements and New Features</title> <list> diff --git a/lib/cosNotification/vsn.mk b/lib/cosNotification/vsn.mk index 0d95ab4853..1677057670 100644 --- a/lib/cosNotification/vsn.mk +++ b/lib/cosNotification/vsn.mk @@ -1,2 +1,2 @@ -COSNOTIFICATION_VSN = 1.2.2 +COSNOTIFICATION_VSN = 1.2.3 diff --git a/lib/cosProperty/doc/src/notes.xml b/lib/cosProperty/doc/src/notes.xml index e5d22982c5..4de246de67 100644 --- a/lib/cosProperty/doc/src/notes.xml +++ b/lib/cosProperty/doc/src/notes.xml @@ -33,7 +33,22 @@ </header> - <section><title>cosProperty 1.2.2</title> + <section><title>cosProperty 1.2.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + +<section><title>cosProperty 1.2.2</title> <section><title>Improvements and New Features</title> <list> diff --git a/lib/cosProperty/vsn.mk b/lib/cosProperty/vsn.mk index 78ba88445d..a3a952346e 100644 --- a/lib/cosProperty/vsn.mk +++ b/lib/cosProperty/vsn.mk @@ -1,2 +1,2 @@ -COSPROPERTY_VSN = 1.2.2 +COSPROPERTY_VSN = 1.2.3 diff --git a/lib/cosTime/doc/src/notes.xml b/lib/cosTime/doc/src/notes.xml index 686d9e6add..16e02f8b1f 100644 --- a/lib/cosTime/doc/src/notes.xml +++ b/lib/cosTime/doc/src/notes.xml @@ -33,7 +33,22 @@ <file>notes.xml</file> </header> - <section><title>cosTime 1.2.2</title> + <section><title>cosTime 1.2.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + +<section><title>cosTime 1.2.2</title> <section><title>Improvements and New Features</title> <list> diff --git a/lib/cosTime/vsn.mk b/lib/cosTime/vsn.mk index 7c9cae2d2f..7d6fcbebcd 100644 --- a/lib/cosTime/vsn.mk +++ b/lib/cosTime/vsn.mk @@ -1,2 +1,2 @@ -COSTIME_VSN = 1.2.2 +COSTIME_VSN = 1.2.3 diff --git a/lib/cosTransactions/doc/src/notes.xml b/lib/cosTransactions/doc/src/notes.xml index 85ace1208b..2401c04c3f 100644 --- a/lib/cosTransactions/doc/src/notes.xml +++ b/lib/cosTransactions/doc/src/notes.xml @@ -33,7 +33,22 @@ <file>notes.xml</file> </header> - <section><title>cosTransactions 1.3.2</title> + <section><title>cosTransactions 1.3.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + +<section><title>cosTransactions 1.3.2</title> <section><title>Improvements and New Features</title> <list> diff --git a/lib/cosTransactions/vsn.mk b/lib/cosTransactions/vsn.mk index ab163d83c2..bba2058231 100644 --- a/lib/cosTransactions/vsn.mk +++ b/lib/cosTransactions/vsn.mk @@ -1 +1 @@ -COSTRANSACTIONS_VSN = 1.3.2 +COSTRANSACTIONS_VSN = 1.3.3 diff --git a/lib/crypto/c_src/Makefile.in b/lib/crypto/c_src/Makefile.in index af7c209c75..31124ba477 100644 --- a/lib/crypto/c_src/Makefile.in +++ b/lib/crypto/c_src/Makefile.in @@ -1,7 +1,7 @@ # # %CopyrightBegin% # -# Copyright Ericsson AB 1999-2016. All Rights Reserved. +# Copyright Ericsson AB 1999-2017. 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. @@ -78,12 +78,16 @@ CRYPTO_STATIC_OBJS = $(OBJDIR)/crypto_static$(TYPEMARKER).o\ NIF_ARCHIVE = $(LIBDIR)/crypto$(TYPEMARKER).a +TEST_ENGINE_OBJS = $(OBJDIR)/otp_test_engine$(TYPEMARKER).o + ifeq ($(findstring win32,$(TARGET)), win32) NIF_LIB = $(LIBDIR)/crypto$(TYPEMARKER).dll CALLBACK_LIB = $(LIBDIR)/crypto_callback$(TYPEMARKER).dll +TEST_ENGINE_LIB = $(LIBDIR)/otp_test_engine$(TYPEMARKER).dll else NIF_LIB = $(LIBDIR)/crypto$(TYPEMARKER).so CALLBACK_LIB = $(LIBDIR)/crypto_callback$(TYPEMARKER).so +TEST_ENGINE_LIB = $(LIBDIR)/otp_test_engine$(TYPEMARKER).so endif ifeq ($(HOST_OS),) @@ -129,10 +133,22 @@ ALL_STATIC_CFLAGS = $(DED_STATIC_CFLAGS) $(INCLUDES) _create_dirs := $(shell mkdir -p $(OBJDIR) $(LIBDIR)) -debug opt valgrind: $(NIF_LIB) $(CALLBACK_LIB) +debug opt valgrind: $(NIF_LIB) $(CALLBACK_LIB) $(TEST_ENGINE_LIB) static_lib: $(NIF_ARCHIVE) +$(OBJDIR)/otp_test_engine$(TYPEMARKER).o: otp_test_engine.c + $(V_at)$(INSTALL_DIR) $(OBJDIR) + $(V_CC) -c -o $@ $(ALL_CFLAGS) $< + +$(LIBDIR)/otp_test_engine$(TYPEMARKER).so: $(TEST_ENGINE_OBJS) + $(V_at)$(INSTALL_DIR) $(LIBDIR) + $(V_LD) $(LDFLAGS) -o $@ $^ $(LDLIBS) $(CRYPTO_LINK_LIB) + +$(LIBDIR)/otp_test_engine$(TYPEMARKER).dll: $(TEST_ENGINE_OBJS) + $(V_at)$(INSTALL_DIR) $(LIBDIR) + $(V_LD) $(LDFLAGS) -o $@ $(SSL_DED_LD_RUNTIME_LIBRARY_PATH) -L$(SSL_LIBDIR) $(TEST_ENGINE_OBJS) -l$(SSL_CRYPTO_LIBNAME) -l$(SSL_SSL_LIBNAME) + $(OBJDIR)/%$(TYPEMARKER).o: %.c $(V_at)$(INSTALL_DIR) $(OBJDIR) $(V_CC) -c -o $@ $(ALL_CFLAGS) $< @@ -170,6 +186,7 @@ ifeq ($(findstring win32,$(TARGET)), win32) rm -f $(LIBDIR)/crypto.debug.dll rm -f $(LIBDIR)/crypto_callback.dll rm -f $(LIBDIR)/crypto_callback.debug.dll + rm -f $(LIBDIR)/otp_test_engine.dll else rm -f $(LIBDIR)/crypto.so rm -f $(LIBDIR)/crypto.debug.so @@ -177,6 +194,7 @@ else rm -f $(LIBDIR)/crypto_callback.so rm -f $(LIBDIR)/crypto_callback.debug.so rm -f $(LIBDIR)/crypto_callback.valgrind.so + rm -f $(LIBDIR)/otp_test_engine.so endif rm -f $(OBJDIR)/crypto.o rm -f $(OBJDIR)/crypto_static.o @@ -187,6 +205,7 @@ endif rm -f $(OBJDIR)/crypto_callback.o rm -f $(OBJDIR)/crypto_callback.debug.o rm -f $(OBJDIR)/crypto_callback.valgrind.o + rm -f $(OBJDIR)/otp_test_engine.o rm -f core *~ docs: @@ -206,6 +225,8 @@ ifeq ($(DYNAMIC_CRYPTO_LIB),yes) $(INSTALL_PROGRAM) $(CALLBACK_OBJS) "$(RELSYSDIR)/priv/obj" $(INSTALL_PROGRAM) $(CALLBACK_LIB) "$(RELSYSDIR)/priv/lib" endif + $(INSTALL_PROGRAM) $(TEST_ENGINE_OBJS) "$(RELSYSDIR)/priv/obj" + $(INSTALL_PROGRAM) $(TEST_ENGINE_LIB) "$(RELSYSDIR)/priv/lib" release_docs_spec: diff --git a/lib/crypto/c_src/crypto.c b/lib/crypto/c_src/crypto.c index 53fe233790..9a3ea07c97 100644 --- a/lib/crypto/c_src/crypto.c +++ b/lib/crypto/c_src/crypto.c @@ -1,4 +1,4 @@ -/* +/* * %CopyrightBegin% * * Copyright Ericsson AB 2010-2017. All Rights Reserved. @@ -19,8 +19,8 @@ */ /* - * Purpose: Dynamically loadable NIF library for cryptography. - * Based on OpenSSL. + * Purpose: Dynamically loadable NIF library for cryptography. + * Based on OpenSSL. */ #ifdef __WIN32__ @@ -60,6 +60,8 @@ #include <openssl/rand.h> #include <openssl/evp.h> #include <openssl/hmac.h> +#include <openssl/engine.h> +#include <openssl/err.h> /* Helper macro to construct a OPENSSL_VERSION_NUMBER. * See openssl/opensslv.h @@ -79,9 +81,9 @@ * * Therefor works tests like this as intendend: * OPENSSL_VERSION_NUMBER >= PACKED_OPENSSL_VERSION_PLAIN(1,0,0) - * (The test is for example "2.4.2" >= "1.0.0" although the test + * (The test is for example "2.4.2" >= "1.0.0" although the test * with the cloned OpenSSL test would be "1.0.1" >= "1.0.0") - * + * * But tests like this gives wrong result: * OPENSSL_VERSION_NUMBER < PACKED_OPENSSL_VERSION_PLAIN(1,1,0) * (The test is false since "2.4.2" < "1.1.0". It should have been @@ -119,6 +121,10 @@ #include <openssl/modes.h> #endif +#if OPENSSL_VERSION_NUMBER >= PACKED_OPENSSL_VERSION(0,9,8,'h') +#define HAS_ENGINE_SUPPORT +#endif + #include "crypto_callback.h" #if OPENSSL_VERSION_NUMBER >= PACKED_OPENSSL_VERSION_PLAIN(0,9,8) \ @@ -173,6 +179,12 @@ # define HAVE_ECB_IVEC_BUG #endif +#define HAVE_RSA_SSLV23_PADDING +#if defined(HAS_LIBRESSL) \ + && LIBRESSL_VERSION_NUMBER >= PACKED_OPENSSL_VERSION_PLAIN(2,6,1) +# undef HAVE_RSA_SSLV23_PADDING +#endif + #if defined(HAVE_CMAC) #include <openssl/cmac.h> #endif @@ -240,7 +252,7 @@ /* This shall correspond to the similar macro in crypto.erl */ /* Current value is: erlang:system_info(context_reductions) * 10 */ -#define MAX_BYTES_TO_NIF 20000 +#define MAX_BYTES_TO_NIF 20000 #define CONSUME_REDS(NifEnv, Ibin) \ do { \ @@ -277,7 +289,7 @@ static HMAC_CTX *HMAC_CTX_new() static void HMAC_CTX_free(HMAC_CTX *ctx) { HMAC_CTX_cleanup(ctx); - return CRYPTO_free(ctx); + CRYPTO_free(ctx); } #define EVP_MD_CTX_new() EVP_MD_CTX_create() @@ -342,6 +354,10 @@ static INLINE void RSA_get0_crt_params(const RSA *r, const BIGNUM **dmp1, const static INLINE int DSA_set0_key(DSA *d, BIGNUM *pub_key, BIGNUM *priv_key); static INLINE int DSA_set0_pqg(DSA *d, BIGNUM *p, BIGNUM *q, BIGNUM *g); +static INLINE void DSA_get0_pqg(const DSA *dsa, + const BIGNUM **p, const BIGNUM **q, const BIGNUM **g); +static INLINE void DSA_get0_key(const DSA *dsa, + const BIGNUM **pub_key, const BIGNUM **priv_key); static INLINE int DSA_set0_key(DSA *d, BIGNUM *pub_key, BIGNUM *priv_key) { @@ -358,6 +374,23 @@ static INLINE int DSA_set0_pqg(DSA *d, BIGNUM *p, BIGNUM *q, BIGNUM *g) return 1; } +static INLINE void +DSA_get0_pqg(const DSA *dsa, const BIGNUM **p, const BIGNUM **q, const BIGNUM **g) +{ + *p = dsa->p; + *q = dsa->q; + *g = dsa->g; +} + +static INLINE void +DSA_get0_key(const DSA *dsa, const BIGNUM **pub_key, const BIGNUM **priv_key) +{ + if (pub_key) *pub_key = dsa->pub_key; + if (priv_key) *priv_key = dsa->priv_key; +} + + + static INLINE int DH_set0_key(DH *dh, BIGNUM *pub_key, BIGNUM *priv_key); static INLINE int DH_set0_pqg(DH *dh, BIGNUM *p, BIGNUM *q, BIGNUM *g); static INLINE int DH_set_length(DH *dh, long length); @@ -387,6 +420,8 @@ static INLINE int DH_set_length(DH *dh, long length) return 1; } + + static INLINE void DH_get0_pqg(const DH *dh, const BIGNUM **p, const BIGNUM **q, const BIGNUM **g) { @@ -398,8 +433,8 @@ DH_get0_pqg(const DH *dh, const BIGNUM **p, const BIGNUM **q, const BIGNUM **g) static INLINE void DH_get0_key(const DH *dh, const BIGNUM **pub_key, const BIGNUM **priv_key) { - *pub_key = dh->pub_key; - *priv_key = dh->priv_key; + if (pub_key) *pub_key = dh->pub_key; + if (priv_key) *priv_key = dh->priv_key; } #else /* End of compatibility definitions. */ @@ -448,6 +483,7 @@ static ERL_NIF_TERM dh_generate_parameters_nif(ErlNifEnv* env, int argc, const E static ERL_NIF_TERM dh_check(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM dh_generate_key_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM dh_compute_key_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM privkey_to_pubkey_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM srp_value_B_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM srp_user_secret_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM srp_host_secret_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); @@ -466,6 +502,22 @@ static ERL_NIF_TERM aes_gcm_decrypt_NO_EVP(ErlNifEnv* env, int argc, const ERL_N static ERL_NIF_TERM chacha20_poly1305_encrypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM chacha20_poly1305_decrypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static int get_engine_load_cmd_list(ErlNifEnv* env, const ERL_NIF_TERM term, char **cmds, int i); +static ERL_NIF_TERM engine_by_id_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM engine_init_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM engine_finish_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM engine_free_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM engine_load_dynamic_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM engine_ctrl_cmd_strings_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM engine_register_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM engine_unregister_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM engine_add_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM engine_remove_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM engine_get_first_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM engine_get_next_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM engine_get_id_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM engine_get_all_methods_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); + /* helpers */ static void init_algorithms_types(ErlNifEnv*); static void init_digest_types(ErlNifEnv* env); @@ -477,6 +529,10 @@ static int term2point(ErlNifEnv* env, ERL_NIF_TERM term, #endif static ERL_NIF_TERM bin_from_bn(ErlNifEnv* env, const BIGNUM *bn); +#ifdef HAS_ENGINE_SUPPORT +static int zero_terminate(ErlNifBinary bin, char **buf); +#endif + static int library_refc = 0; /* number of users of this dynamic library */ static ErlNifFunc nif_funcs[] = { @@ -516,6 +572,7 @@ static ErlNifFunc nif_funcs[] = { {"dh_check", 1, dh_check}, {"dh_generate_key_nif", 4, dh_generate_key_nif}, {"dh_compute_key_nif", 3, dh_compute_key_nif}, + {"privkey_to_pubkey_nif", 2, privkey_to_pubkey_nif}, {"srp_value_B_nif", 5, srp_value_B_nif}, {"srp_user_secret_nif", 7, srp_user_secret_nif}, {"srp_host_secret_nif", 5, srp_host_secret_nif}, @@ -529,12 +586,27 @@ static ErlNifFunc nif_funcs[] = { {"aes_gcm_decrypt", 5, aes_gcm_decrypt}, {"chacha20_poly1305_encrypt", 4, chacha20_poly1305_encrypt}, - {"chacha20_poly1305_decrypt", 5, chacha20_poly1305_decrypt} + {"chacha20_poly1305_decrypt", 5, chacha20_poly1305_decrypt}, + + {"engine_by_id_nif", 1, engine_by_id_nif}, + {"engine_init_nif", 1, engine_init_nif}, + {"engine_finish_nif", 1, engine_finish_nif}, + {"engine_free_nif", 1, engine_free_nif}, + {"engine_load_dynamic_nif", 0, engine_load_dynamic_nif}, + {"engine_ctrl_cmd_strings_nif", 3, engine_ctrl_cmd_strings_nif}, + {"engine_register_nif", 2, engine_register_nif}, + {"engine_unregister_nif", 2, engine_unregister_nif}, + {"engine_add_nif", 1, engine_add_nif}, + {"engine_remove_nif", 1, engine_remove_nif}, + {"engine_get_first_nif", 0, engine_get_first_nif}, + {"engine_get_next_nif", 1, engine_get_next_nif}, + {"engine_get_id_nif", 1, engine_get_id_nif}, + {"engine_get_all_methods_nif", 0, engine_get_all_methods_nif} + }; ERL_NIF_INIT(crypto,nif_funcs,load,NULL,upgrade,unload) - #define MD5_CTX_LEN (sizeof(MD5_CTX)) #define MD4_CTX_LEN (sizeof(MD4_CTX)) #define RIPEMD160_CTX_LEN (sizeof(RIPEMD160_CTX)) @@ -593,7 +665,9 @@ static ERL_NIF_TERM atom_rsa_oaep_md; static ERL_NIF_TERM atom_rsa_pad; /* backwards compatibility */ static ERL_NIF_TERM atom_rsa_padding; static ERL_NIF_TERM atom_rsa_pkcs1_pss_padding; +#ifdef HAVE_RSA_SSLV23_PADDING static ERL_NIF_TERM atom_rsa_sslv23_padding; +#endif static ERL_NIF_TERM atom_rsa_x931_padding; static ERL_NIF_TERM atom_rsa_pss_saltlen; static ERL_NIF_TERM atom_sha224; @@ -603,7 +677,33 @@ static ERL_NIF_TERM atom_sha512; static ERL_NIF_TERM atom_md5; static ERL_NIF_TERM atom_ripemd160; - +#ifdef HAS_ENGINE_SUPPORT +static ERL_NIF_TERM atom_bad_engine_method; +static ERL_NIF_TERM atom_bad_engine_id; +static ERL_NIF_TERM atom_ctrl_cmd_failed; +static ERL_NIF_TERM atom_engine_init_failed; +static ERL_NIF_TERM atom_register_engine_failed; +static ERL_NIF_TERM atom_add_engine_failed; +static ERL_NIF_TERM atom_remove_engine_failed; +static ERL_NIF_TERM atom_engine_method_not_supported; + +static ERL_NIF_TERM atom_engine_method_rsa; +static ERL_NIF_TERM atom_engine_method_dsa; +static ERL_NIF_TERM atom_engine_method_dh; +static ERL_NIF_TERM atom_engine_method_rand; +static ERL_NIF_TERM atom_engine_method_ecdh; +static ERL_NIF_TERM atom_engine_method_ecdsa; +static ERL_NIF_TERM atom_engine_method_ciphers; +static ERL_NIF_TERM atom_engine_method_digests; +static ERL_NIF_TERM atom_engine_method_store; +static ERL_NIF_TERM atom_engine_method_pkey_meths; +static ERL_NIF_TERM atom_engine_method_pkey_asn1_meths; +static ERL_NIF_TERM atom_engine_method_ec; + +static ERL_NIF_TERM atom_engine; +static ERL_NIF_TERM atom_key_id; +static ERL_NIF_TERM atom_password; +#endif static ErlNifResourceType* hmac_context_rtype; struct hmac_context @@ -728,11 +828,13 @@ static struct cipher_type_t cipher_types[] = static struct cipher_type_t* get_cipher_type(ERL_NIF_TERM type, size_t key_len); + /* #define PRINTF_ERR0(FMT) enif_fprintf(stderr, FMT "\n") #define PRINTF_ERR1(FMT, A1) enif_fprintf(stderr, FMT "\n", A1) #define PRINTF_ERR2(FMT, A1, A2) enif_fprintf(stderr, FMT "\n", A1, A2) */ + #define PRINTF_ERR0(FMT) #define PRINTF_ERR1(FMT,A1) #define PRINTF_ERR2(FMT,A1,A2) @@ -758,6 +860,23 @@ static void evp_cipher_ctx_dtor(ErlNifEnv* env, struct evp_cipher_ctx* ctx) { } #endif +// Engine +#ifdef HAS_ENGINE_SUPPORT +static ErlNifResourceType* engine_ctx_rtype; +struct engine_ctx { + ENGINE *engine; + char *id; +}; +static void engine_ctx_dtor(ErlNifEnv* env, struct engine_ctx* ctx) { + PRINTF_ERR0("engine_ctx_dtor"); + if(ctx->id) { + PRINTF_ERR1(" non empty ctx->id=%s", ctx->id); + enif_free(ctx->id); + } else + PRINTF_ERR0(" empty ctx->id=NULL"); +} +#endif + static int verify_lib_version(void) { const unsigned long libv = SSLeay(); @@ -793,7 +912,7 @@ static char crypto_callback_name[] = "crypto_callback"; static int change_basename(ErlNifBinary* bin, char* buf, int bufsz, const char* newfile) { int i; - + for (i = bin->size; i > 0; i--) { if (bin->data[i-1] == '/') break; @@ -869,12 +988,23 @@ static int initialize(ErlNifEnv* env, ERL_NIF_TERM load_info) return __LINE__; } #endif +#ifdef HAS_ENGINE_SUPPORT + engine_ctx_rtype = enif_open_resource_type(env, NULL, "ENGINE_CTX", + (ErlNifResourceDtor*) engine_ctx_dtor, + ERL_NIF_RT_CREATE|ERL_NIF_RT_TAKEOVER, + NULL); + if (!engine_ctx_rtype) { + PRINTF_ERR0("CRYPTO: Could not open resource type 'ENGINE_CTX'"); + return __LINE__; + } + if (library_refc > 0) { /* Repeated loading of this library (module upgrade). * Atoms and callbacks are already set, we are done. */ return 0; } +#endif atom_true = enif_make_atom(env,"true"); atom_false = enif_make_atom(env,"false"); @@ -942,7 +1072,9 @@ static int initialize(ErlNifEnv* env, ERL_NIF_TERM load_info) atom_rsa_pad = enif_make_atom(env,"rsa_pad"); /* backwards compatibility */ atom_rsa_padding = enif_make_atom(env,"rsa_padding"); atom_rsa_pkcs1_pss_padding = enif_make_atom(env,"rsa_pkcs1_pss_padding"); +#ifdef HAVE_RSA_SSLV23_PADDING atom_rsa_sslv23_padding = enif_make_atom(env,"rsa_sslv23_padding"); +#endif atom_rsa_x931_padding = enif_make_atom(env,"rsa_x931_padding"); atom_rsa_pss_saltlen = enif_make_atom(env,"rsa_pss_saltlen"); atom_sha224 = enif_make_atom(env,"sha224"); @@ -952,6 +1084,33 @@ static int initialize(ErlNifEnv* env, ERL_NIF_TERM load_info) atom_md5 = enif_make_atom(env,"md5"); atom_ripemd160 = enif_make_atom(env,"ripemd160"); +#ifdef HAS_ENGINE_SUPPORT + atom_bad_engine_method = enif_make_atom(env,"bad_engine_method"); + atom_bad_engine_id = enif_make_atom(env,"bad_engine_id"); + atom_ctrl_cmd_failed = enif_make_atom(env,"ctrl_cmd_failed"); + atom_engine_init_failed = enif_make_atom(env,"engine_init_failed"); + atom_engine_method_not_supported = enif_make_atom(env,"engine_method_not_supported"); + atom_add_engine_failed = enif_make_atom(env,"add_engine_failed"); + atom_remove_engine_failed = enif_make_atom(env,"remove_engine_failed"); + + atom_engine_method_rsa = enif_make_atom(env,"engine_method_rsa"); + atom_engine_method_dsa = enif_make_atom(env,"engine_method_dsa"); + atom_engine_method_dh = enif_make_atom(env,"engine_method_dh"); + atom_engine_method_rand = enif_make_atom(env,"engine_method_rand"); + atom_engine_method_ecdh = enif_make_atom(env,"engine_method_ecdh"); + atom_engine_method_ecdsa = enif_make_atom(env,"engine_method_ecdsa"); + atom_engine_method_store = enif_make_atom(env,"engine_method_store"); + atom_engine_method_ciphers = enif_make_atom(env,"engine_method_ciphers"); + atom_engine_method_digests = enif_make_atom(env,"engine_method_digests"); + atom_engine_method_pkey_meths = enif_make_atom(env,"engine_method_pkey_meths"); + atom_engine_method_pkey_asn1_meths = enif_make_atom(env,"engine_method_pkey_asn1_meths"); + atom_engine_method_ec = enif_make_atom(env,"engine_method_ec"); + + atom_engine = enif_make_atom(env,"engine"); + atom_key_id = enif_make_atom(env,"key_id"); + atom_password = enif_make_atom(env,"password"); +#endif + init_digest_types(env); init_cipher_types(env); init_algorithms_types(env); @@ -973,24 +1132,24 @@ static int initialize(ErlNifEnv* env, ERL_NIF_TERM load_info) #else /* !HAVE_DYNAMIC_CRYPTO_LIB */ funcp = &get_crypto_callbacks; #endif - + #ifdef OPENSSL_THREADS enif_system_info(&sys_info, sizeof(sys_info)); if (sys_info.scheduler_threads > 1) { - nlocks = CRYPTO_num_locks(); + nlocks = CRYPTO_num_locks(); } /* else no need for locks */ #endif - + ccb = (*funcp)(nlocks); - + if (!ccb || ccb->sizeof_me != sizeof(*ccb)) { PRINTF_ERR0("Invalid 'crypto_callbacks'"); return __LINE__; } - + CRYPTO_set_mem_functions(ccb->crypto_alloc, ccb->crypto_realloc, ccb->crypto_free); - + #ifdef OPENSSL_THREADS if (nlocks > 0) { CRYPTO_set_locking_callback(ccb->locking_function); @@ -1186,11 +1345,11 @@ static ERL_NIF_TERM info_lib(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[] * Version string is still from library though. */ - memcpy(enif_make_new_binary(env, name_sz, &name_term), libname, name_sz); + memcpy(enif_make_new_binary(env, name_sz, &name_term), libname, name_sz); memcpy(enif_make_new_binary(env, ver_sz, &ver_term), ver, ver_sz); return enif_make_list1(env, enif_make_tuple3(env, name_term, - enif_make_int(env, ver_num), + enif_make_int(env, ver_num), ver_term)); } @@ -1225,6 +1384,8 @@ static ERL_NIF_TERM enable_fips_mode(ErlNifEnv* env, int argc, const ERL_NIF_TER } } + +#if defined(HAVE_EC) static ERL_NIF_TERM make_badarg_maybe(ErlNifEnv* env) { ERL_NIF_TERM reason; @@ -1233,6 +1394,7 @@ static ERL_NIF_TERM make_badarg_maybe(ErlNifEnv* env) else return enif_make_badarg(env); } +#endif static ERL_NIF_TERM hash_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) {/* (Type, Data) */ @@ -1668,7 +1830,7 @@ static ERL_NIF_TERM hmac_update_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM {/* (Context, Data) */ ErlNifBinary data; struct hmac_context* obj; - + if (!enif_get_resource(env, argv[0], hmac_context_rtype, (void**)&obj) || !enif_inspect_iolist_as_binary(env, argv[1], &data)) { return enif_make_badarg(env); @@ -1704,13 +1866,13 @@ static ERL_NIF_TERM hmac_final_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM enif_mutex_unlock(obj->mtx); return enif_make_badarg(env); } - + HMAC_Final(obj->ctx, mac_buf, &mac_len); HMAC_CTX_free(obj->ctx); obj->alive = 0; enif_mutex_unlock(obj->mtx); - if (argc == 2 && req_len < mac_len) { + if (argc == 2 && req_len < mac_len) { /* Only truncate to req_len bytes if asked. */ mac_len = req_len; } @@ -2021,7 +2183,7 @@ static ERL_NIF_TERM aes_ctr_stream_init(ErlNifEnv* env, int argc, const ERL_NIF_ } static ERL_NIF_TERM aes_ctr_stream_encrypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) -{/* ({Key, IVec, ECount, Num}, Data) */ +{/* ({Key, IVec, ECount, Num}, Data) */ ErlNifBinary key_bin, ivec_bin, text_bin, ecount_bin; AES_KEY aes_key; unsigned int num; @@ -2042,14 +2204,14 @@ static ERL_NIF_TERM aes_ctr_stream_encrypt(ErlNifEnv* env, int argc, const ERL_N return enif_make_badarg(env); } - ivec2_buf = enif_make_new_binary(env, ivec_bin.size, &ivec2_term); + ivec2_buf = enif_make_new_binary(env, ivec_bin.size, &ivec2_term); ecount2_buf = enif_make_new_binary(env, ecount_bin.size, &ecount2_term); - + memcpy(ivec2_buf, ivec_bin.data, 16); memcpy(ecount2_buf, ecount_bin.data, ecount_bin.size); AES_ctr128_encrypt((unsigned char *) text_bin.data, - enif_make_new_binary(env, text_bin.size, &cipher_term), + enif_make_new_binary(env, text_bin.size, &cipher_term), text_bin.size, &aes_key, ivec2_buf, ecount2_buf, &num); num2_term = enif_make_uint(env, num); @@ -2352,7 +2514,7 @@ out_err: } static ERL_NIF_TERM strong_rand_bytes_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) -{/* (Bytes) */ +{/* (Bytes) */ unsigned bytes; unsigned char* data; ERL_NIF_TERM ret; @@ -2446,7 +2608,7 @@ static ERL_NIF_TERM rand_uniform_nif(ErlNifEnv* env, int argc, const ERL_NIF_TER bn_to = BN_new(); BN_sub(bn_to, bn_rand, bn_from); - BN_pseudo_rand_range(bn_rand, bn_to); + BN_pseudo_rand_range(bn_rand, bn_to); BN_add(bn_rand, bn_rand, bn_from); dlen = BN_num_bytes(bn_rand); data = enif_make_new_binary(env, dlen+4, &ret); @@ -2464,7 +2626,7 @@ static ERL_NIF_TERM mod_exp_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM arg BIGNUM *bn_base=NULL, *bn_exponent=NULL, *bn_modulo=NULL, *bn_result; BN_CTX *bn_ctx; unsigned char* ptr; - unsigned dlen; + unsigned dlen; unsigned bin_hdr; /* return type: 0=plain binary, 4: mpint */ unsigned extra_byte; ERL_NIF_TERM ret; @@ -2485,7 +2647,7 @@ static ERL_NIF_TERM mod_exp_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM arg dlen = BN_num_bytes(bn_result); extra_byte = bin_hdr && BN_is_bit_set(bn_result, dlen*8-1); ptr = enif_make_new_binary(env, bin_hdr+extra_byte+dlen, &ret); - if (bin_hdr) { + if (bin_hdr) { put_int32(ptr, extra_byte+dlen); ptr[4] = 0; /* extra zeroed byte to ensure a positive mpint */ ptr += bin_hdr + extra_byte; @@ -2545,6 +2707,7 @@ static struct cipher_type_t* get_cipher_type(ERL_NIF_TERM type, size_t key_len) return NULL; } + static ERL_NIF_TERM do_exor(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) {/* (Data1, Data2) */ ErlNifBinary d1, d2; @@ -2578,7 +2741,7 @@ static ERL_NIF_TERM rc4_set_key(ErlNifEnv* env, int argc, const ERL_NIF_TERM arg return enif_make_badarg(env); } RC4_set_key((RC4_KEY*)enif_make_new_binary(env, sizeof(RC4_KEY), &ret), - key.size, key.data); + key.size, key.data); return ret; #else return enif_raise_exception(env, atom_notsup); @@ -2846,7 +3009,7 @@ static ERL_NIF_TERM rsa_generate_key_nif(ErlNifEnv* env, int argc, const ERL_NIF static ERL_NIF_TERM dh_generate_parameters_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) {/* (PrimeLen, Generator) */ int prime_len, generator; - DH* dh_params; + DH* dh_params = NULL; int p_len, g_len; unsigned char *p_ptr, *g_ptr; ERL_NIF_TERM ret_p, ret_g; @@ -2857,8 +3020,8 @@ static ERL_NIF_TERM dh_generate_parameters_nif(ErlNifEnv* env, int argc, const E return enif_make_badarg(env); } - dh_params = DH_generate_parameters(prime_len, generator, NULL, NULL); - if (dh_params == NULL) { + + if (DH_generate_parameters_ex(dh_params, prime_len, generator, NULL)) { return atom_error; } DH_get0_pqg(dh_params, &dh_p, &dh_q, &dh_g); @@ -2871,7 +3034,7 @@ static ERL_NIF_TERM dh_generate_parameters_nif(ErlNifEnv* env, int argc, const E BN_bn2bin(dh_g, g_ptr); ERL_VALGRIND_MAKE_MEM_DEFINED(p_ptr, p_len); ERL_VALGRIND_MAKE_MEM_DEFINED(g_ptr, g_len); - return enif_make_list2(env, ret_p, ret_g); + return enif_make_list2(env, ret_p, ret_g); } static ERL_NIF_TERM dh_check(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) @@ -2881,9 +3044,9 @@ static ERL_NIF_TERM dh_check(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[] ERL_NIF_TERM ret, head, tail; BIGNUM *dh_p, *dh_g; - if (!enif_get_list_cell(env, argv[0], &head, &tail) + if (!enif_get_list_cell(env, argv[0], &head, &tail) || !get_bn_from_bin(env, head, &dh_p) - || !enif_get_list_cell(env, tail, &head, &tail) + || !enif_get_list_cell(env, tail, &head, &tail) || !get_bn_from_bin(env, head, &dh_g) || !enif_is_empty_list(env,tail)) { @@ -2900,12 +3063,12 @@ static ERL_NIF_TERM dh_check(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[] else if (i & DH_NOT_SUITABLE_GENERATOR) ret = atom_not_suitable_generator; else ret = enif_make_tuple2(env, atom_unknown, enif_make_uint(env, i)); } - else { /* Check Failed */ + else { /* Check Failed */ ret = enif_make_tuple2(env, atom_error, atom_check_failed); } DH_free(dh_params); return ret; -} +} static ERL_NIF_TERM dh_generate_key_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) {/* (PrivKey|undefined, DHParams=[P,G], Mpint, Len|0) */ @@ -3007,7 +3170,7 @@ static ERL_NIF_TERM dh_compute_key_nif(ErlNifEnv* env, int argc, const ERL_NIF_T i = DH_compute_key(ret_bin.data, other_pub_key, dh_params); if (i > 0) { if (i != ret_bin.size) { - enif_realloc_binary(&ret_bin, i); + enif_realloc_binary(&ret_bin, i); } ret = enif_make_binary(env, &ret_bin); } @@ -3803,9 +3966,69 @@ static int get_pkey_sign_options(ErlNifEnv *env, ERL_NIF_TERM algorithm, ERL_NIF } +#ifdef HAS_ENGINE_SUPPORT +static int get_engine_and_key_id(ErlNifEnv *env, ERL_NIF_TERM key, char ** id, ENGINE **e) +{ + ERL_NIF_TERM engine_res, key_id_term; + struct engine_ctx *ctx; + ErlNifBinary key_id_bin; + + if (!enif_get_map_value(env, key, atom_engine, &engine_res) || + !enif_get_resource(env, engine_res, engine_ctx_rtype, (void**)&ctx) || + !enif_get_map_value(env, key, atom_key_id, &key_id_term) || + !enif_inspect_binary(env, key_id_term, &key_id_bin)) { + return 0; + } + else { + *e = ctx->engine; + return zero_terminate(key_id_bin, id); + } +} + + +static char *get_key_password(ErlNifEnv *env, ERL_NIF_TERM key) { + ERL_NIF_TERM tmp_term; + ErlNifBinary pwd_bin; + char *pwd; + if (enif_get_map_value(env, key, atom_password, &tmp_term) && + enif_inspect_binary(env, tmp_term, &pwd_bin) && + zero_terminate(pwd_bin, &pwd) + ) return pwd; + + return NULL; +} + +static int zero_terminate(ErlNifBinary bin, char **buf) { + *buf = enif_alloc(bin.size+1); + if (!*buf) + return 0; + memcpy(*buf, bin.data, bin.size); + *(*buf+bin.size) = 0; + return 1; +} +#endif + static int get_pkey_private_key(ErlNifEnv *env, ERL_NIF_TERM algorithm, ERL_NIF_TERM key, EVP_PKEY **pkey) { - if (algorithm == atom_rsa) { + if (enif_is_map(env, key)) { +#ifdef HAS_ENGINE_SUPPORT + /* Use key stored in engine */ + ENGINE *e; + char *id; + char *password; + + if (!get_engine_and_key_id(env, key, &id, &e)) + return PKEY_BADARG; + password = get_key_password(env, key); + *pkey = ENGINE_load_private_key(e, id, NULL, password); + if (!*pkey) + return PKEY_BADARG; + enif_free(id); +#else + return PKEY_BADARG; +#endif + } + else if (algorithm == atom_rsa) { RSA *rsa = RSA_new(); if (!get_rsa_private_key(env, key, rsa)) { @@ -3866,7 +4089,24 @@ static int get_pkey_private_key(ErlNifEnv *env, ERL_NIF_TERM algorithm, ERL_NIF_ static int get_pkey_public_key(ErlNifEnv *env, ERL_NIF_TERM algorithm, ERL_NIF_TERM key, EVP_PKEY **pkey) { - if (algorithm == atom_rsa) { + if (enif_is_map(env, key)) { +#ifdef HAS_ENGINE_SUPPORT + /* Use key stored in engine */ + ENGINE *e; + char *id; + char *password; + + if (!get_engine_and_key_id(env, key, &id, &e)) + return PKEY_BADARG; + password = get_key_password(env, key); + *pkey = ENGINE_load_public_key(e, id, NULL, password); + if (!pkey) + return PKEY_BADARG; + enif_free(id); +#else + return PKEY_BADARG; +#endif + } else if (algorithm == atom_rsa) { RSA *rsa = RSA_new(); if (!get_rsa_public_key(env, key, rsa)) { @@ -3924,7 +4164,7 @@ static int get_pkey_public_key(ErlNifEnv *env, ERL_NIF_TERM algorithm, ERL_NIF_T } static ERL_NIF_TERM pkey_sign_nif(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) -{/* (Algorithm, Type, Data|{digest,Digest}, Key, Options) */ +{/* (Algorithm, Type, Data|{digest,Digest}, Key|#{}, Options) */ int i; const EVP_MD *md = NULL; unsigned char md_value[EVP_MAX_MD_SIZE]; @@ -3944,6 +4184,13 @@ enif_get_atom(env,argv[0],buf,1024,ERL_NIF_LATIN1); printf("algo=%s ",buf); enif_get_atom(env,argv[1],buf,1024,ERL_NIF_LATIN1); printf("hash=%s ",buf); printf("\r\n"); */ + +#ifndef HAS_ENGINE_SUPPORT + if (enif_is_map(env, argv[3])) { + return atom_notsup; + } +#endif + i = get_pkey_sign_digest(env, argv[0], argv[1], argv[2], md_value, &md, &tbs, &tbslen); if (i != PKEY_OK) { if (i == PKEY_NOTSUP) @@ -3965,10 +4212,9 @@ printf("\r\n"); } #ifdef HAS_EVP_PKEY_CTX -/* printf("EVP interface\r\n"); - */ ctx = EVP_PKEY_CTX_new(pkey, NULL); if (!ctx) goto badarg; + if (EVP_PKEY_sign_init(ctx) <= 0) goto badarg; if (md != NULL && EVP_PKEY_CTX_set_signature_md(ctx, md) <= 0) goto badarg; @@ -4070,6 +4316,12 @@ static ERL_NIF_TERM pkey_verify_nif(ErlNifEnv *env, int argc, const ERL_NIF_TERM unsigned char *tbs; /* data to be signed */ size_t tbslen; +#ifndef HAS_ENGINE_SUPPORT + if (enif_is_map(env, argv[4])) { + return atom_notsup; + } +#endif + if (!enif_inspect_binary(env, argv[3], &sig_bin)) { return enif_make_badarg(env); } @@ -4095,7 +4347,7 @@ static ERL_NIF_TERM pkey_verify_nif(ErlNifEnv *env, int argc, const ERL_NIF_TERM } #ifdef HAS_EVP_PKEY_CTX -/* printf("EVP interface\r\n"); +/* printf("EVP interface\r\n"); */ ctx = EVP_PKEY_CTX_new(pkey, NULL); if (!ctx) goto badarg; @@ -4207,8 +4459,10 @@ static int get_pkey_crypt_options(ErlNifEnv *env, ERL_NIF_TERM algorithm, ERL_NI opt->rsa_padding = RSA_PKCS1_PADDING; } else if (tpl_terms[1] == atom_rsa_pkcs1_oaep_padding) { opt->rsa_padding = RSA_PKCS1_OAEP_PADDING; +#ifdef HAVE_RSA_SSLV23_PADDING } else if (tpl_terms[1] == atom_rsa_sslv23_padding) { opt->rsa_padding = RSA_SSLV23_PADDING; +#endif } else if (tpl_terms[1] == atom_rsa_x931_padding) { opt->rsa_padding = RSA_X931_PADDING; } else if (tpl_terms[1] == atom_rsa_no_padding) { @@ -4274,13 +4528,22 @@ static ERL_NIF_TERM pkey_crypt_nif(ErlNifEnv *env, int argc, const ERL_NIF_TERM #endif PKeyCryptOptions crypt_opt; ErlNifBinary in_bin, out_bin, tmp_bin; - size_t outlen, tmplen; + size_t outlen; +#ifdef HAVE_RSA_SSLV23_PADDING + size_t tmplen; +#endif int is_private = (argv[4] == atom_true), is_encrypt = (argv[5] == atom_true); int algo_init = 0; /* char algo[1024]; */ - + +#ifndef HAS_ENGINE_SUPPORT + if (enif_is_map(env, argv[2])) { + return atom_notsup; + } +#endif + if (!enif_inspect_binary(env, argv[1], &in_bin)) { return enif_make_badarg(env); } @@ -4348,6 +4611,7 @@ static ERL_NIF_TERM pkey_crypt_nif(ErlNifEnv *env, int argc, const ERL_NIF_TERM if (crypt_opt.signature_md != NULL && EVP_PKEY_CTX_set_signature_md(ctx, crypt_opt.signature_md) <= 0) goto badarg; +#ifdef HAVE_RSA_SSLV23_PADDING if (crypt_opt.rsa_padding == RSA_SSLV23_PADDING) { if (is_encrypt) { RSA *rsa = EVP_PKEY_get1_RSA(pkey); @@ -4359,9 +4623,11 @@ static ERL_NIF_TERM pkey_crypt_nif(ErlNifEnv *env, int argc, const ERL_NIF_TERM in_bin = tmp_bin; } if (EVP_PKEY_CTX_set_rsa_padding(ctx, RSA_NO_PADDING) <= 0) goto badarg; - } else { + } else +#endif + { if (EVP_PKEY_CTX_set_rsa_padding(ctx, crypt_opt.rsa_padding) <= 0) goto badarg; - } + } #ifdef HAVE_RSA_OAEP_MD if (crypt_opt.rsa_padding == RSA_PKCS1_OAEP_PADDING) { if (crypt_opt.rsa_oaep_md != NULL @@ -4409,7 +4675,6 @@ static ERL_NIF_TERM pkey_crypt_nif(ErlNifEnv *env, int argc, const ERL_NIF_TERM enif_alloc_binary(outlen, &out_bin); - ERL_VALGRIND_ASSERT_MEM_DEFINED(out_bin.data, out_bin.size); if (is_private) { if (is_encrypt) { /* private_encrypt */ @@ -4481,6 +4746,7 @@ static ERL_NIF_TERM pkey_crypt_nif(ErlNifEnv *env, int argc, const ERL_NIF_TERM #endif if ((i > 0) && argv[0] == atom_rsa && !is_encrypt) { +#ifdef HAVE_RSA_SSLV23_PADDING if (crypt_opt.rsa_padding == RSA_SSLV23_PADDING) { RSA *rsa = EVP_PKEY_get1_RSA(pkey); unsigned char *p; @@ -4498,6 +4764,7 @@ static ERL_NIF_TERM pkey_crypt_nif(ErlNifEnv *env, int argc, const ERL_NIF_TERM i = 1; } } +#endif } if (tmp_bin.data != NULL) { @@ -4542,6 +4809,80 @@ static ERL_NIF_TERM pkey_crypt_nif(ErlNifEnv *env, int argc, const ERL_NIF_TERM /*--------------------------------*/ +static ERL_NIF_TERM privkey_to_pubkey_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ /* (Algorithm, PrivKey | KeyMap) */ + EVP_PKEY *pkey; + ERL_NIF_TERM alg = argv[0]; + ERL_NIF_TERM result[8]; + if (get_pkey_private_key(env, alg, argv[1], &pkey) != PKEY_OK) { + return enif_make_badarg(env); + } + + if (alg == atom_rsa) { + const BIGNUM *n = NULL, *e = NULL, *d = NULL; + RSA *rsa = EVP_PKEY_get1_RSA(pkey); + if (rsa) { + RSA_get0_key(rsa, &n, &e, &d); + result[0] = bin_from_bn(env, e); // Exponent E + result[1] = bin_from_bn(env, n); // Modulus N = p*q + EVP_PKEY_free(pkey); + return enif_make_list_from_array(env, result, 2); + } + + } else if (argv[0] == atom_dss) { + const BIGNUM *p = NULL, *q = NULL, *g = NULL, *pub_key = NULL; + DSA *dsa = EVP_PKEY_get1_DSA(pkey); + if (dsa) { + DSA_get0_pqg(dsa, &p, &q, &g); + DSA_get0_key(dsa, &pub_key, NULL); + result[0] = bin_from_bn(env, p); + result[1] = bin_from_bn(env, q); + result[2] = bin_from_bn(env, g); + result[3] = bin_from_bn(env, pub_key); + EVP_PKEY_free(pkey); + return enif_make_list_from_array(env, result, 4); + } + + } else if (argv[0] == atom_ecdsa) { +#if defined(HAVE_EC) + /* not yet implemented + EC_KEY *ec = EVP_PKEY_get1_EC_KEY(pkey); + if (ec) { + / * Example of result: + { + Curve = {Field, Prime, Point, Order, CoFactor} = + { + Field = {prime_field,<<255,...,255>>}, + Prime = {<<255,...,252>>, + <<90,...,75>>, + <<196,...,144>> + }, + Point = <<4,...,245>>, + Order = <<255,...,81>>, + CoFactor = <<1>> + }, + Key = <<151,...,62>> + } + or + { + Curve = + {characteristic_two_field, + M, + Basis = {tpbasis, _} + | {ppbasis, k1, k2, k3} + }, + Key + } + * / + EVP_PKEY_free(pkey); + return enif_make_list_from_array(env, ..., ...); + */ +#endif + } + + if (pkey) EVP_PKEY_free(pkey); + return enif_make_badarg(env); +} /*================================================================*/ @@ -4554,3 +4895,600 @@ static ERL_NIF_TERM rand_seed_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM a RAND_seed(seed_bin.data,seed_bin.size); return atom_ok; } + +/*================================================================*/ +/* Engine */ +/*================================================================*/ +static ERL_NIF_TERM engine_by_id_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (EngineId) */ +#ifdef HAS_ENGINE_SUPPORT + ERL_NIF_TERM ret; + ErlNifBinary engine_id_bin; + char *engine_id; + ENGINE *engine; + struct engine_ctx *ctx; + + // Get Engine Id + if(!enif_inspect_binary(env, argv[0], &engine_id_bin)) { + PRINTF_ERR0("engine_by_id_nif Leaved: badarg"); + return enif_make_badarg(env); + } else { + engine_id = enif_alloc(engine_id_bin.size+1); + (void) memcpy(engine_id, engine_id_bin.data, engine_id_bin.size); + engine_id[engine_id_bin.size] = '\0'; + } + + engine = ENGINE_by_id(engine_id); + if(!engine) { + enif_free(engine_id); + PRINTF_ERR0("engine_by_id_nif Leaved: {error, bad_engine_id}"); + return enif_make_tuple2(env, atom_error, atom_bad_engine_id); + } + + ctx = enif_alloc_resource(engine_ctx_rtype, sizeof(struct engine_ctx)); + ctx->engine = engine; + ctx->id = engine_id; + + ret = enif_make_resource(env, ctx); + enif_release_resource(ctx); + + return enif_make_tuple2(env, atom_ok, ret); +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM engine_init_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Engine) */ +#ifdef HAS_ENGINE_SUPPORT + ERL_NIF_TERM ret = atom_ok; + struct engine_ctx *ctx; + + // Get Engine + if (!enif_get_resource(env, argv[0], engine_ctx_rtype, (void**)&ctx)) { + PRINTF_ERR0("engine_init_nif Leaved: Parameter not an engine resource object"); + return enif_make_badarg(env); + } + if (!ENGINE_init(ctx->engine)) { + //ERR_print_errors_fp(stderr); + PRINTF_ERR0("engine_init_nif Leaved: {error, engine_init_failed}"); + return enif_make_tuple2(env, atom_error, atom_engine_init_failed); + } + + return ret; +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM engine_free_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Engine) */ +#ifdef HAS_ENGINE_SUPPORT + struct engine_ctx *ctx; + + // Get Engine + if (!enif_get_resource(env, argv[0], engine_ctx_rtype, (void**)&ctx)) { + PRINTF_ERR0("engine_free_nif Leaved: Parameter not an engine resource object"); + return enif_make_badarg(env); + } + + ENGINE_free(ctx->engine); + return atom_ok; +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM engine_finish_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Engine) */ +#ifdef HAS_ENGINE_SUPPORT + struct engine_ctx *ctx; + + // Get Engine + if (!enif_get_resource(env, argv[0], engine_ctx_rtype, (void**)&ctx)) { + PRINTF_ERR0("engine_finish_nif Leaved: Parameter not an engine resource object"); + return enif_make_badarg(env); + } + + ENGINE_finish(ctx->engine); + return atom_ok; +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM engine_load_dynamic_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* () */ +#ifdef HAS_ENGINE_SUPPORT + ENGINE_load_dynamic(); + return atom_ok; +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM engine_ctrl_cmd_strings_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Engine, Commands) */ +#ifdef HAS_ENGINE_SUPPORT + ERL_NIF_TERM ret = atom_ok; + unsigned int cmds_len = 0; + char **cmds = NULL; + struct engine_ctx *ctx; + int i, optional = 0; + + // Get Engine + if (!enif_get_resource(env, argv[0], engine_ctx_rtype, (void**)&ctx)) { + PRINTF_ERR0("engine_ctrl_cmd_strings_nif Leaved: Parameter not an engine resource object"); + return enif_make_badarg(env); + } + + PRINTF_ERR1("Engine Id: %s\r\n", ENGINE_get_id(ctx->engine)); + + // Get Command List + if(!enif_get_list_length(env, argv[1], &cmds_len)) { + PRINTF_ERR0("engine_ctrl_cmd_strings_nif Leaved: Bad Command List"); + return enif_make_badarg(env); + } else { + cmds_len *= 2; // Key-Value list from erlang + cmds = enif_alloc((cmds_len+1)*sizeof(char*)); + if(get_engine_load_cmd_list(env, argv[1], cmds, 0)) { + PRINTF_ERR0("engine_ctrl_cmd_strings_nif Leaved: Couldn't read Command List"); + ret = enif_make_badarg(env); + goto error; + } + } + + if(!enif_get_int(env, argv[2], &optional)) { + PRINTF_ERR0("engine_ctrl_cmd_strings_nif Leaved: Parameter optional not an integer"); + return enif_make_badarg(env); + } + + for(i = 0; i < cmds_len; i+=2) { + PRINTF_ERR2("Cmd: %s:%s\r\n", + cmds[i] ? cmds[i] : "(NULL)", + cmds[i+1] ? cmds[i+1] : "(NULL)"); + if(!ENGINE_ctrl_cmd_string(ctx->engine, cmds[i], cmds[i+1], optional)) { + PRINTF_ERR2("Command failed: %s:%s\r\n", + cmds[i] ? cmds[i] : "(NULL)", + cmds[i+1] ? cmds[i+1] : "(NULL)"); + //ENGINE_free(ctx->engine); + ret = enif_make_tuple2(env, atom_error, atom_ctrl_cmd_failed); + PRINTF_ERR0("engine_ctrl_cmd_strings_nif Leaved: {error, ctrl_cmd_failed}"); + goto error; + } + } + + error: + for(i = 0; cmds != NULL && cmds[i] != NULL; i++) + enif_free(cmds[i]); + enif_free(cmds); + return ret; +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM engine_add_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Engine) */ +#ifdef HAS_ENGINE_SUPPORT + struct engine_ctx *ctx; + + // Get Engine + if (!enif_get_resource(env, argv[0], engine_ctx_rtype, (void**)&ctx)) { + PRINTF_ERR0("engine_add_nif Leaved: Parameter not an engine resource object"); + return enif_make_badarg(env); + } + + if (!ENGINE_add(ctx->engine)) { + PRINTF_ERR0("engine_add_nif Leaved: {error, add_engine_failed}"); + return enif_make_tuple2(env, atom_error, atom_add_engine_failed); + } + return atom_ok; +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM engine_remove_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Engine) */ +#ifdef HAS_ENGINE_SUPPORT + struct engine_ctx *ctx; + + // Get Engine + if (!enif_get_resource(env, argv[0], engine_ctx_rtype, (void**)&ctx)) { + PRINTF_ERR0("engine_remove_nif Leaved: Parameter not an engine resource object"); + return enif_make_badarg(env); + } + + if (!ENGINE_remove(ctx->engine)) { + PRINTF_ERR0("engine_remove_nif Leaved: {error, remove_engine_failed}"); + return enif_make_tuple2(env, atom_error, atom_remove_engine_failed); + } + return atom_ok; +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM engine_register_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Engine, EngineMethod) */ +#ifdef HAS_ENGINE_SUPPORT + struct engine_ctx *ctx; + unsigned int method; + + // Get Engine + if (!enif_get_resource(env, argv[0], engine_ctx_rtype, (void**)&ctx)) { + PRINTF_ERR0("engine_register_nif Leaved: Parameter not an engine resource object"); + return enif_make_badarg(env); + } + // Get Method + if (!enif_get_uint(env, argv[1], &method)) { + PRINTF_ERR0("engine_register_nif Leaved: Parameter Method not an uint"); + return enif_make_badarg(env); + } + + switch(method) + { +#ifdef ENGINE_METHOD_RSA + case ENGINE_METHOD_RSA: + if (!ENGINE_register_RSA(ctx->engine)) + return enif_make_tuple2(env, atom_error, atom_register_engine_failed); + break; +#endif +#ifdef ENGINE_METHOD_DSA + case ENGINE_METHOD_DSA: + if (!ENGINE_register_DSA(ctx->engine)) + return enif_make_tuple2(env, atom_error, atom_register_engine_failed); + break; +#endif +#ifdef ENGINE_METHOD_DH + case ENGINE_METHOD_DH: + if (!ENGINE_register_DH(ctx->engine)) + return enif_make_tuple2(env, atom_error, atom_register_engine_failed); + break; +#endif +#ifdef ENGINE_METHOD_RAND + case ENGINE_METHOD_RAND: + if (!ENGINE_register_RAND(ctx->engine)) + return enif_make_tuple2(env, atom_error, atom_register_engine_failed); + break; +#endif +#ifdef ENGINE_METHOD_ECDH + case ENGINE_METHOD_ECDH: + if (!ENGINE_register_ECDH(ctx->engine)) + return enif_make_tuple2(env, atom_error, atom_register_engine_failed); + break; +#endif +#ifdef ENGINE_METHOD_ECDSA + case ENGINE_METHOD_ECDSA: + if (!ENGINE_register_ECDSA(ctx->engine)) + return enif_make_tuple2(env, atom_error, atom_register_engine_failed); + break; +#endif +#ifdef ENGINE_METHOD_STORE + case ENGINE_METHOD_STORE: + if (!ENGINE_register_STORE(ctx->engine)) + return enif_make_tuple2(env, atom_error, atom_register_engine_failed); + break; +#endif +#ifdef ENGINE_METHOD_CIPHERS + case ENGINE_METHOD_CIPHERS: + if (!ENGINE_register_ciphers(ctx->engine)) + return enif_make_tuple2(env, atom_error, atom_register_engine_failed); + break; +#endif +#ifdef ENGINE_METHOD_DIGESTS + case ENGINE_METHOD_DIGESTS: + if (!ENGINE_register_digests(ctx->engine)) + return enif_make_tuple2(env, atom_error, atom_register_engine_failed); + break; +#endif +#ifdef ENGINE_METHOD_PKEY_METHS + case ENGINE_METHOD_PKEY_METHS: + if (!ENGINE_register_pkey_meths(ctx->engine)) + return enif_make_tuple2(env, atom_error, atom_register_engine_failed); + break; +#endif +#ifdef ENGINE_METHOD_PKEY_ASN1_METHS + case ENGINE_METHOD_PKEY_ASN1_METHS: + if (!ENGINE_register_pkey_asn1_meths(ctx->engine)) + return enif_make_tuple2(env, atom_error, atom_register_engine_failed); + break; +#endif +#ifdef ENGINE_METHOD_EC + case ENGINE_METHOD_EC: + if (!ENGINE_register_EC(ctx->engine)) + return enif_make_tuple2(env, atom_error, atom_register_engine_failed); + break; +#endif + default: + return enif_make_tuple2(env, atom_error, atom_engine_method_not_supported); + break; + } + return atom_ok; +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM engine_unregister_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Engine, EngineMethod) */ +#ifdef HAS_ENGINE_SUPPORT + struct engine_ctx *ctx; + unsigned int method; + + // Get Engine + if (!enif_get_resource(env, argv[0], engine_ctx_rtype, (void**)&ctx)) { + PRINTF_ERR0("engine_unregister_nif Leaved: Parameter not an engine resource object"); + return enif_make_badarg(env); + } + // Get Method + if (!enif_get_uint(env, argv[1], &method)) { + PRINTF_ERR0("engine_unregister_nif Leaved: Parameter Method not an uint"); + return enif_make_badarg(env); + } + + switch(method) + { +#ifdef ENGINE_METHOD_RSA + case ENGINE_METHOD_RSA: + ENGINE_unregister_RSA(ctx->engine); + break; +#endif +#ifdef ENGINE_METHOD_DSA + case ENGINE_METHOD_DSA: + ENGINE_unregister_DSA(ctx->engine); + break; +#endif +#ifdef ENGINE_METHOD_DH + case ENGINE_METHOD_DH: + ENGINE_unregister_DH(ctx->engine); + break; +#endif +#ifdef ENGINE_METHOD_RAND + case ENGINE_METHOD_RAND: + ENGINE_unregister_RAND(ctx->engine); + break; +#endif +#ifdef ENGINE_METHOD_ECDH + case ENGINE_METHOD_ECDH: + ENGINE_unregister_ECDH(ctx->engine); + break; +#endif +#ifdef ENGINE_METHOD_ECDSA + case ENGINE_METHOD_ECDSA: + ENGINE_unregister_ECDSA(ctx->engine); + break; +#endif +#ifdef ENGINE_METHOD_STORE + case ENGINE_METHOD_STORE: + ENGINE_unregister_STORE(ctx->engine); + break; +#endif +#ifdef ENGINE_METHOD_CIPHERS + case ENGINE_METHOD_CIPHERS: + ENGINE_unregister_ciphers(ctx->engine); + break; +#endif +#ifdef ENGINE_METHOD_DIGESTS + case ENGINE_METHOD_DIGESTS: + ENGINE_unregister_digests(ctx->engine); + break; +#endif +#ifdef ENGINE_METHOD_PKEY_METHS + case ENGINE_METHOD_PKEY_METHS: + ENGINE_unregister_pkey_meths(ctx->engine); + break; +#endif +#ifdef ENGINE_METHOD_PKEY_ASN1_METHS + case ENGINE_METHOD_PKEY_ASN1_METHS: + ENGINE_unregister_pkey_asn1_meths(ctx->engine); + break; +#endif +#ifdef ENGINE_METHOD_EC + case ENGINE_METHOD_EC: + ENGINE_unregister_EC(ctx->engine); + break; +#endif + default: + break; + } + return atom_ok; +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM engine_get_first_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Engine) */ +#ifdef HAS_ENGINE_SUPPORT + ERL_NIF_TERM ret; + ENGINE *engine; + ErlNifBinary engine_bin; + struct engine_ctx *ctx; + + engine = ENGINE_get_first(); + if(!engine) { + enif_alloc_binary(0, &engine_bin); + engine_bin.size = 0; + return enif_make_tuple2(env, atom_ok, enif_make_binary(env, &engine_bin)); + } + + ctx = enif_alloc_resource(engine_ctx_rtype, sizeof(struct engine_ctx)); + ctx->engine = engine; + ctx->id = NULL; + + ret = enif_make_resource(env, ctx); + enif_release_resource(ctx); + + return enif_make_tuple2(env, atom_ok, ret); +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM engine_get_next_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Engine) */ +#ifdef HAS_ENGINE_SUPPORT + ERL_NIF_TERM ret; + ENGINE *engine; + ErlNifBinary engine_bin; + struct engine_ctx *ctx, *next_ctx; + + // Get Engine + if (!enif_get_resource(env, argv[0], engine_ctx_rtype, (void**)&ctx)) { + PRINTF_ERR0("engine_get_next_nif Leaved: Parameter not an engine resource object"); + return enif_make_badarg(env); + } + engine = ENGINE_get_next(ctx->engine); + if (!engine) { + enif_alloc_binary(0, &engine_bin); + engine_bin.size = 0; + return enif_make_tuple2(env, atom_ok, enif_make_binary(env, &engine_bin)); + } + + next_ctx = enif_alloc_resource(engine_ctx_rtype, sizeof(struct engine_ctx)); + next_ctx->engine = engine; + next_ctx->id = NULL; + + ret = enif_make_resource(env, next_ctx); + enif_release_resource(next_ctx); + + return enif_make_tuple2(env, atom_ok, ret); +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM engine_get_id_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Engine) */ +#ifdef HAS_ENGINE_SUPPORT + ErlNifBinary engine_id_bin; + const char *engine_id; + int size; + struct engine_ctx *ctx; + + // Get Engine + if (!enif_get_resource(env, argv[0], engine_ctx_rtype, (void**)&ctx)) { + PRINTF_ERR0("engine_get_id_nif Leaved: Parameter not an engine resource object"); + return enif_make_badarg(env); + } + + engine_id = ENGINE_get_id(ctx->engine); + if (!engine_id) { + enif_alloc_binary(0, &engine_id_bin); + engine_id_bin.size = 0; + return enif_make_tuple2(env, atom_ok, enif_make_binary(env, &engine_id_bin)); + } + + size = strlen(engine_id); + enif_alloc_binary(size, &engine_id_bin); + engine_id_bin.size = size; + memcpy(engine_id_bin.data, engine_id, size); + + return enif_make_tuple2(env, atom_ok, enif_make_binary(env, &engine_id_bin)); +#else + return atom_notsup; +#endif +} + +static int get_engine_load_cmd_list(ErlNifEnv* env, const ERL_NIF_TERM term, char **cmds, int i) +{ +#ifdef HAS_ENGINE_SUPPORT + ERL_NIF_TERM head, tail; + const ERL_NIF_TERM *tmp_tuple; + ErlNifBinary tmpbin; + int arity; + char* tmpstr; + + if(!enif_is_empty_list(env, term)) { + if(!enif_get_list_cell(env, term, &head, &tail)) { + cmds[i] = NULL; + return -1; + } else { + if(!enif_get_tuple(env, head, &arity, &tmp_tuple) || arity != 2) { + cmds[i] = NULL; + return -1; + } else { + if(!enif_inspect_binary(env, tmp_tuple[0], &tmpbin)) { + cmds[i] = NULL; + return -1; + } else { + tmpstr = enif_alloc(tmpbin.size+1); + (void) memcpy(tmpstr, tmpbin.data, tmpbin.size); + tmpstr[tmpbin.size] = '\0'; + cmds[i++] = tmpstr; + } + if(!enif_inspect_binary(env, tmp_tuple[1], &tmpbin)) { + cmds[i] = NULL; + return -1; + } else { + if(tmpbin.size == 0) + cmds[i++] = NULL; + else { + tmpstr = enif_alloc(tmpbin.size+1); + (void) memcpy(tmpstr, tmpbin.data, tmpbin.size); + tmpstr[tmpbin.size] = '\0'; + cmds[i++] = tmpstr; + } + } + return get_engine_load_cmd_list(env, tail, cmds, i); + } + } + } else { + cmds[i] = NULL; + return 0; + } +#else + return atom_notsup; +#endif +} + +static ERL_NIF_TERM engine_get_all_methods_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* () */ +#ifdef HAS_ENGINE_SUPPORT + ERL_NIF_TERM method_array[12]; + int i = 0; + +#ifdef ENGINE_METHOD_RSA + method_array[i++] = atom_engine_method_rsa; +#endif +#ifdef ENGINE_METHOD_DSA + method_array[i++] = atom_engine_method_dsa; +#endif +#ifdef ENGINE_METHOD_DH + method_array[i++] = atom_engine_method_dh; +#endif +#ifdef ENGINE_METHOD_RAND + method_array[i++] = atom_engine_method_rand; +#endif +#ifdef ENGINE_METHOD_ECDH + method_array[i++] = atom_engine_method_ecdh; +#endif +#ifdef ENGINE_METHOD_ECDSA + method_array[i++] = atom_engine_method_ecdsa; +#endif +#ifdef ENGINE_METHOD_STORE + method_array[i++] = atom_engine_method_store; +#endif +#ifdef ENGINE_METHOD_CIPHERS + method_array[i++] = atom_engine_method_ciphers; +#endif +#ifdef ENGINE_METHOD_DIGESTS + method_array[i++] = atom_engine_method_digests; +#endif +#ifdef ENGINE_METHOD_PKEY_METHS + method_array[i++] = atom_engine_method_pkey_meths; +#endif +#ifdef ENGINE_METHOD_PKEY_ASN1_METHS + method_array[i++] = atom_engine_method_pkey_asn1_meths; +#endif +#ifdef ENGINE_METHOD_EC + method_array[i++] = atom_engine_method_ec; +#endif + + return enif_make_list_from_array(env, method_array, i); +#else + return atom_notsup; +#endif +} diff --git a/lib/crypto/c_src/otp_test_engine.c b/lib/crypto/c_src/otp_test_engine.c new file mode 100644 index 0000000000..5c6122c06a --- /dev/null +++ b/lib/crypto/c_src/otp_test_engine.c @@ -0,0 +1,264 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2017-2017. 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% + */ + +#ifdef _WIN32 +#define OPENSSL_OPT_WINDLL +#endif +#include <stdio.h> +#include <string.h> + +#include <openssl/engine.h> +#include <openssl/md5.h> +#include <openssl/rsa.h> +#include <openssl/pem.h> + +#define PACKED_OPENSSL_VERSION(MAJ, MIN, FIX, P) \ + ((((((((MAJ << 8) | MIN) << 8 ) | FIX) << 8) | (P-'a'+1)) << 4) | 0xf) + +#define PACKED_OPENSSL_VERSION_PLAIN(MAJ, MIN, FIX) \ + PACKED_OPENSSL_VERSION(MAJ,MIN,FIX,('a'-1)) + +#if OPENSSL_VERSION_NUMBER < PACKED_OPENSSL_VERSION_PLAIN(1,1,0) \ + || defined(LIBRESSL_VERSION_NUMBER) +#define OLD +#endif + +static const char *test_engine_id = "MD5"; +static const char *test_engine_name = "MD5 test engine"; + +/* The callback that does the job of fetching keys on demand by the Engine */ +EVP_PKEY* test_key_load(ENGINE *er, const char *id, UI_METHOD *ui_method, void *callback_data); + + +static int test_init(ENGINE *e) { + printf("OTP Test Engine Initializatzion!\r\n"); + + /* Load all digest and cipher algorithms. Needed for password protected private keys */ + OpenSSL_add_all_algorithms(); + + return 111; +} + +static void add_test_data(unsigned char *md, unsigned int len) +{ + unsigned int i; + + for (i=0; i<len; i++) { + md[i] = (unsigned char)(i & 0xff); + } +} + +/* MD5 part */ +#undef data +#ifdef OLD +#define data(ctx) ((MD5_CTX *)ctx->md_data) +#endif + +static int test_engine_md5_init(EVP_MD_CTX *ctx) { + fprintf(stderr, "MD5 initialized\r\n"); +#ifdef OLD + return MD5_Init(data(ctx)); +#else + return 1; +#endif +} + +static int test_engine_md5_update(EVP_MD_CTX *ctx,const void *data, size_t count) +{ + fprintf(stderr, "MD5 update\r\n"); +#ifdef OLD + return MD5_Update(data(ctx), data, (size_t)count); +#else + return 1; +#endif +} + +static int test_engine_md5_final(EVP_MD_CTX *ctx,unsigned char *md) { +#ifdef OLD + int ret; + + fprintf(stderr, "MD5 final size of EVP_MD: %lu\r\n", sizeof(EVP_MD)); + ret = MD5_Final(md, data(ctx)); + + if (ret > 0) { + add_test_data(md, MD5_DIGEST_LENGTH); + } + return ret; +#else + fprintf(stderr, "MD5 final\r\n"); + add_test_data(md, MD5_DIGEST_LENGTH); + return 1; +#endif +} + +#ifdef OLD +static EVP_MD test_engine_md5_method= { + NID_md5, /* The name ID for MD5 */ + NID_undef, /* IGNORED: MD5 with private key encryption NID */ + MD5_DIGEST_LENGTH, /* Size of MD5 result, in bytes */ + 0, /* Flags */ + test_engine_md5_init, /* digest init */ + test_engine_md5_update, /* digest update */ + test_engine_md5_final, /* digest final */ + NULL, /* digest copy */ + NULL, /* digest cleanup */ + EVP_PKEY_NULL_method, /* IGNORED: pkey methods */ + MD5_CBLOCK, /* Internal blocksize, see rfc1321/md5.h */ + sizeof(EVP_MD *) + sizeof(MD5_CTX), + NULL, /* IGNORED: control function */ +}; +#endif + +static int test_digest_ids[] = {NID_md5}; + +static int test_engine_digest_selector(ENGINE *e, const EVP_MD **digest, + const int **nids, int nid) { + int ok = 1; + if (!digest) { + *nids = test_digest_ids; + fprintf(stderr, "Digest is empty! Nid:%d\r\n", nid); + return 2; + } + fprintf(stderr, "Digest no %d requested\r\n",nid); + if (nid == NID_md5) { +#ifdef OLD + *digest = &test_engine_md5_method; +#else + EVP_MD *md = EVP_MD_meth_new(NID_md5, NID_undef); + if (!md || + !EVP_MD_meth_set_result_size(md, MD5_DIGEST_LENGTH) || + !EVP_MD_meth_set_flags(md, 0) || + !EVP_MD_meth_set_init(md, test_engine_md5_init) || + !EVP_MD_meth_set_update(md, test_engine_md5_update) || + !EVP_MD_meth_set_final(md, test_engine_md5_final) || + !EVP_MD_meth_set_copy(md, NULL) || + !EVP_MD_meth_set_cleanup(md, NULL) || + !EVP_MD_meth_set_input_blocksize(md, MD5_CBLOCK) || + !EVP_MD_meth_set_app_datasize(md, sizeof(EVP_MD *) + sizeof(MD5_CTX)) || + !EVP_MD_meth_set_ctrl(md, NULL)) + { + ok = 0; + *digest = NULL; + } else + { + *digest = md; + } +#endif + } + else { + ok = 0; + *digest = NULL; + } + + return ok; +} + + +static int bind_helper(ENGINE * e, const char *id) +{ + if (!ENGINE_set_id(e, test_engine_id) || + !ENGINE_set_name(e, test_engine_name) || + !ENGINE_set_init_function(e, test_init) || + !ENGINE_set_digests(e, &test_engine_digest_selector) || + /* For testing of key storage in an Engine: */ + !ENGINE_set_load_privkey_function(e, &test_key_load) || + !ENGINE_set_load_pubkey_function(e, &test_key_load) + ) + return 0; + + return 1; +} + +IMPLEMENT_DYNAMIC_CHECK_FN(); + +IMPLEMENT_DYNAMIC_BIND_FN(bind_helper); + +/******************************************************** + * + * Engine storage simulation + * + */ +int pem_passwd_cb_fun(char *buf, int size, int rwflag, void *password); + +EVP_PKEY* test_key_load(ENGINE *er, const char *id, UI_METHOD *ui_method, void *callback_data) +{ + EVP_PKEY *pkey = NULL; + FILE *f = fopen(id, "r"); + + if (!f) { + fprintf(stderr, "%s:%d fopen(%s) failed\r\n", __FILE__,__LINE__,id); + return NULL; + } + + /* First try to read as a private key. If that fails, try to read as a public key: */ + pkey = PEM_read_PrivateKey(f, NULL, pem_passwd_cb_fun, callback_data); + if (!pkey) { + /* ERR_print_errors_fp (stderr); */ + fclose(f); + f = fopen(id, "r"); + pkey = PEM_read_PUBKEY(f, NULL, NULL, NULL); + } + fclose(f); + + if (!pkey) { + fprintf(stderr, "%s:%d Key read from file %s failed.\r\n", __FILE__,__LINE__,id); + if (callback_data) + fprintf(stderr, "Pwd = \"%s\".\r\n", (char *)callback_data); + fprintf(stderr, "Contents of file \"%s\":\r\n",id); + f = fopen(id, "r"); + { /* Print the contents of the key file */ + char c; + while (!feof(f)) { + switch (c=fgetc(f)) { + case '\n': + case '\r': putc('\r',stderr); putc('\n',stderr); break; + default: putc(c, stderr); + } + } + } + fprintf(stderr, "File contents printed.\r\n"); + fclose(f); + return NULL; + } + + return pkey; +} + + +int pem_passwd_cb_fun(char *buf, int size, int rwflag, void *password) +{ + int i; + + fprintf(stderr, "In pem_passwd_cb_fun\r\n"); + if (!password) + return 0; + + i = strlen(password); + if (i < size) { + /* whole pwd (incl terminating 0) fits */ + fprintf(stderr, "Got FULL pwd %d(%d) chars\r\n", i, size); + memcpy(buf, (char*)password, i+1); + return i+1; + } else { + fprintf(stderr, "Got TO LONG pwd %d(%d) chars\r\n", i, size); + /* meaningless with a truncated password */ + return 0; + } +} diff --git a/lib/crypto/doc/src/Makefile b/lib/crypto/doc/src/Makefile index 9c503b8fe0..aa987d2b39 100644 --- a/lib/crypto/doc/src/Makefile +++ b/lib/crypto/doc/src/Makefile @@ -9,11 +9,11 @@ # 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. -# +# # The Initial Developer of the Original Code is Ericsson Utvecklings AB. # Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings # AB. All Rights Reserved.'' -# +# # $Id$ # include $(ERL_TOP)/make/target.mk @@ -38,13 +38,13 @@ XML_APPLICATION_FILES = ref_man.xml XML_REF3_FILES = crypto.xml XML_REF6_FILES = crypto_app.xml -XML_PART_FILES = release_notes.xml usersguide.xml -XML_CHAPTER_FILES = notes.xml licenses.xml fips.xml +XML_PART_FILES = usersguide.xml +XML_CHAPTER_FILES = notes.xml licenses.xml fips.xml engine_load.xml engine_keys.xml BOOK_FILES = book.xml XML_FILES = $(BOOK_FILES) $(XML_APPLICATION_FILES) $(XML_REF3_FILES) $(XML_REF6_FILES) \ - $(XML_PART_FILES) $(XML_CHAPTER_FILES) + $(XML_PART_FILES) $(XML_CHAPTER_FILES) GIF_FILES = @@ -63,9 +63,9 @@ HTML_REF_MAN_FILE = $(HTMLDIR)/index.html TOP_PDF_FILE = $(PDFDIR)/$(APPLICATION)-$(VSN).pdf # ---------------------------------------------------- -# FLAGS +# FLAGS # ---------------------------------------------------- -XML_FLAGS += +XML_FLAGS += # ---------------------------------------------------- # Targets @@ -73,7 +73,6 @@ XML_FLAGS += $(HTMLDIR)/%.gif: %.gif $(INSTALL_DATA) $< $@ - docs: pdf html man $(TOP_PDF_FILE): $(XML_FILES) @@ -86,7 +85,7 @@ man: $(MAN3_FILES) $(MAN6_FILES) gifs: $(GIF_FILES:%=$(HTMLDIR)/%) -debug opt valgrind: +debug opt valgrind: clean clean_docs clean_tex: rm -rf $(HTMLDIR)/* @@ -97,7 +96,7 @@ clean clean_docs clean_tex: # ---------------------------------------------------- # Release Target -# ---------------------------------------------------- +# ---------------------------------------------------- include $(ERL_TOP)/make/otp_release_targets.mk release_docs_spec: docs @@ -114,4 +113,3 @@ release_docs_spec: docs release_spec: - diff --git a/lib/crypto/doc/src/crypto.xml b/lib/crypto/doc/src/crypto.xml index 8c30d3d50c..3a5efd0bea 100644 --- a/lib/crypto/doc/src/crypto.xml +++ b/lib/crypto/doc/src/crypto.xml @@ -11,7 +11,7 @@ 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 @@ -19,7 +19,6 @@ 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>crypto</title> @@ -68,11 +67,11 @@ <section> <title>DATA TYPES </title> - - <code>key_value() = integer() | binary() </code> + + <code>key_value() = integer() | binary() </code> <p>Always <c>binary()</c> when used as return value</p> - <code>rsa_public() = [key_value()] = [E, N] </code> + <code>rsa_public() = [key_value()] = [E, N] </code> <p> Where E is the public exponent and N is public modulus. </p> <code>rsa_private() = [key_value()] = [E, N, D] | [E, N, D, P1, P2, E1, E2, C] </code> @@ -85,7 +84,7 @@ <code>dss_public() = [key_value()] = [P, Q, G, Y] </code> <p>Where P, Q and G are the dss parameters and Y is the public key.</p> - <code>dss_private() = [key_value()] = [P, Q, G, X] </code> + <code>dss_private() = [key_value()] = [P, Q, G, X] </code> <p>Where P, Q and G are the dss parameters and X is the private key.</p> <code>srp_public() = key_value() </code> @@ -109,15 +108,16 @@ <code>ecdh_private() = key_value() </code> - <code>ecdh_params() = ec_named_curve() | ec_explicit_curve()</code> + <code>ecdh_params() = ec_named_curve() | ec_explicit_curve()</code> <code>ec_explicit_curve() = - {ec_field(), Prime :: key_value(), Point :: key_value(), Order :: integer(), CoFactor :: none | integer()} </code> + {ec_field(), Prime :: key_value(), Point :: key_value(), Order :: integer(), + CoFactor :: none | integer()} </code> <code>ec_field() = {prime_field, Prime :: integer()} | {characteristic_two_field, M :: integer(), Basis :: ec_basis()}</code> - <code>ec_basis() = {tpbasis, K :: non_neg_integer()} | + <code>ec_basis() = {tpbasis, K :: non_neg_integer()} | {ppbasis, K1 :: non_neg_integer(), K2 :: non_neg_integer(), K3 :: non_neg_integer()} | onbasis</code> @@ -136,16 +136,34 @@ See also <seealso marker="#supports-0">crypto:supports/0</seealso> </p> + <marker id="engine_key_ref_type"/> + <code>engine_key_ref() = #{engine := engine_ref(), + key_id := key_id(), + password => password()}</code> + + <code>engine_ref() = term()</code> + <p>The result of a call to <seealso marker="#engine_load-3">engine_load/3</seealso>. + </p> + + <code>key_id() = string() | binary()</code> + <p>Identifies the key to be used. The format depends on the loaded engine. It is passed to + the <c>ENGINE_load_(private|public)_key</c> functions in libcrypto. + </p> + + <code>password() = string() | binary()</code> + <p>The key's password + </p> + <code>stream_cipher() = rc4 | aes_ctr </code> - <code>block_cipher() = aes_cbc | aes_cfb8 | aes_cfb128 | aes_ige256 | blowfish_cbc | + <code>block_cipher() = aes_cbc | aes_cfb8 | aes_cfb128 | aes_ige256 | blowfish_cbc | blowfish_cfb64 | des_cbc | des_cfb | des3_cbc | des3_cfb | des_ede3 | rc2_cbc </code> - <code>aead_cipher() = aes_gcm | chacha20_poly1305 </code> + <code>aead_cipher() = aes_gcm | chacha20_poly1305 </code> - <code>stream_key() = aes_key() | rc4_key() </code> + <code>stream_key() = aes_key() | rc4_key() </code> - <code>block_key() = aes_key() | blowfish_key() | des_key()| des3_key() </code> + <code>block_key() = aes_key() | blowfish_key() | des_key()| des3_key() </code> <code>aes_key() = iodata() </code> <p>Key length is 128, 192 or 256 bits</p> @@ -174,13 +192,17 @@ Note that both md4 and md5 are recommended only for compatibility with existing applications. </p> <code> cipher_algorithms() = aes_cbc | aes_cfb8 | aes_cfb128 | aes_ctr | aes_gcm | - aes_ige256 | blowfish_cbc | blowfish_cfb64 | chacha20_poly1305 | des_cbc | des_cfb | - des3_cbc | des3_cfb | des_ede3 | rc2_cbc | rc4 </code> - <code> mac_algorithms() = hmac | cmac</code> - <code> public_key_algorithms() = rsa |dss | ecdsa | dh | ecdh | ec_gf2m</code> + aes_ige256 | blowfish_cbc | blowfish_cfb64 | chacha20_poly1305 | des_cbc | + des_cfb | des3_cbc | des3_cfb | des_ede3 | rc2_cbc | rc4 </code> + <code> mac_algorithms() = hmac | cmac</code> + <code> public_key_algorithms() = rsa |dss | ecdsa | dh | ecdh | ec_gf2m</code> <p>Note that ec_gf2m is not strictly a public key algorithm, but a restriction on what curves are supported with ecdsa and ecdh. </p> + <code>engine_method_type() = engine_method_rsa | engine_method_dsa | engine_method_dh | + engine_method_rand | engine_method_ecdh | engine_method_ecdsa | + engine_method_ciphers | engine_method_digests | engine_method_store | + engine_method_pkey_meths | engine_method_pkey_asn1_meths</code> </section> @@ -261,13 +283,13 @@ is not supported by the underlying OpenSSL implementation.</p> </desc> </func> - + <func> <name>bytes_to_integer(Bin) -> Integer </name> <fsummary>Convert binary representation, of an integer, to an Erlang integer.</fsummary> <type> <v>Bin = binary() - as returned by crypto functions</v> - + <v>Integer = integer() </v> </type> <desc> @@ -439,7 +461,7 @@ </type> <desc> <p>Updates the HMAC represented by <c>Context</c> using the given <c>Data</c>. <c>Context</c> - must have been generated using an HMAC init function (such as + must have been generated using an HMAC init function (such as <seealso marker="#hmac_init-2">hmac_init</seealso>). <c>Data</c> can be any length. <c>NewContext</c> must be passed into the next call to <c>hmac_update</c> or to one of the functions <seealso marker="#hmac_final-1">hmac_final</seealso> and @@ -580,7 +602,7 @@ <type> <v>Type = rsa</v> <v>CipherText = binary()</v> - <v>PrivateKey = rsa_private()</v> + <v>PrivateKey = rsa_private() | engine_key_ref()</v> <v>Padding = rsa_pkcs1_padding | rsa_pkcs1_oaep_padding | rsa_no_padding</v> <v>PlainText = binary()</v> </type> @@ -594,7 +616,22 @@ </p> </desc> </func> - + + <func> + <name>privkey_to_pubkey(Type, EnginePrivateKeyRef) -> PublicKey</name> + <fsummary>Fetches a public key from an Engine stored private key.</fsummary> + <type> + <v>Type = rsa | dss</v> + <v>EnginePrivateKeyRef = engine_key_ref()</v> + <v>PublicKey = rsa_public() | dss_public()</v> + </type> + <desc> + <p>Fetches the corresponding public key from a private key stored in an Engine. + The key must be of the type indicated by the Type parameter. + </p> + </desc> + </func> + <func> <name>private_encrypt(Type, PlainText, PrivateKey, Padding) -> CipherText</name> <fsummary>Encrypts PlainText using the private Key.</fsummary> @@ -605,7 +642,7 @@ than <c>byte_size(N)-11</c> if <c>rsa_pkcs1_padding</c> is used, and <c>byte_size(N)</c> if <c>rsa_no_padding</c> is used, where N is public modulus of the RSA key.</d> - <v>PrivateKey = rsa_private()</v> + <v>PrivateKey = rsa_private() | engine_key_ref()</v> <v>Padding = rsa_pkcs1_padding | rsa_no_padding</v> <v>CipherText = binary()</v> </type> @@ -624,7 +661,7 @@ <type> <v>Type = rsa</v> <v>CipherText = binary()</v> - <v>PublicKey = rsa_public() </v> + <v>PublicKey = rsa_public() | engine_key_ref()</v> <v>Padding = rsa_pkcs1_padding | rsa_no_padding</v> <v>PlainText = binary()</v> </type> @@ -649,7 +686,7 @@ than <c>byte_size(N)-11</c> if <c>rsa_pkcs1_padding</c> is used, and <c>byte_size(N)</c> if <c>rsa_no_padding</c> is used, where N is public modulus of the RSA key.</d> - <v>PublicKey = rsa_public()</v> + <v>PublicKey = rsa_public() | engine_key_ref()</v> <v>Padding = rsa_pkcs1_padding | rsa_pkcs1_oaep_padding | rsa_no_padding</v> <v>CipherText = binary()</v> </type> @@ -702,7 +739,7 @@ signed or it is the hashed value of "cleartext" i.e. the digest (plaintext).</d> <v>DigestType = rsa_digest_type() | dss_digest_type() | ecdsa_digest_type()</v> - <v>Key = rsa_private() | dss_private() | [ecdh_private(),ecdh_params()]</v> + <v>Key = rsa_private() | dss_private() | [ecdh_private(),ecdh_params()] | engine_key_ref()</v> <v>Options = sign_options()</v> </type> <desc> @@ -1014,7 +1051,7 @@ _FloatValue = rand:uniform(). % [0.0; 1.0[</pre> or it is the hashed value of "cleartext" i.e. the digest (plaintext).</d> <v>DigestType = rsa_digest_type() | dss_digest_type() | ecdsa_digest_type()</v> <v>Signature = binary()</v> - <v>Key = rsa_public() | dss_public() | [ecdh_public(),ecdh_params()]</v> + <v>Key = rsa_public() | dss_public() | [ecdh_public(),ecdh_params()] | engine_key_ref()</v> <v>Options = sign_options()</v> </type> <desc> @@ -1026,6 +1063,175 @@ _FloatValue = rand:uniform(). % [0.0; 1.0[</pre> </desc> </func> + <!-- Engine functions --> + <func> + <name>engine_get_all_methods() -> Result</name> + <fsummary>Return list of all possible engine methods</fsummary> + <type> + <v>Result = [EngineMethod::atom()]</v> + </type> + <desc> + <p> + Returns a list of all possible engine methods. + </p> + <p> + May throw exception notsup in case there is + no engine support in the underlying OpenSSL implementation. + </p> + <p> + See also the chapter <seealso marker="crypto:engine_load#engine_load">Engine Load</seealso> + in the User's Guide. + </p> + </desc> + </func> + + <func> + <name>engine_load(EngineId, PreCmds, PostCmds) -> Result</name> + <fsummary>Dynamical load an encryption engine</fsummary> + <type> + <v>EngineId = unicode:chardata()</v> + <v>PreCmds, PostCmds = [{unicode:chardata(), unicode:chardata()}]</v> + <v>Result = {ok, Engine::term()} | {error, Reason::term()}</v> + </type> + <desc> + <p> + Loads the OpenSSL engine given by <c>EngineId</c> if it is available and then returns ok and + an engine handle. This function is the same as calling <c>engine_load/4</c> with + <c>EngineMethods</c> set to a list of all the possible methods. An error tuple is + returned if the engine can't be loaded. + </p> + <p> + The function throws a badarg if the parameters are in wrong format. + It may also throw the exception notsup in case there is + no engine support in the underlying OpenSSL implementation. + </p> + <p> + See also the chapter <seealso marker="crypto:engine_load#engine_load">Engine Load</seealso> + in the User's Guide. + </p> + </desc> + </func> + + <func> + <name>engine_load(EngineId, PreCmds, PostCmds, EngineMethods) -> Result</name> + <fsummary>Dynamical load an encryption engine</fsummary> + <type> + <v>EngineId = unicode:chardata()</v> + <v>PreCmds, PostCmds = [{unicode:chardata(), unicode:chardata()}]</v> + <v>EngineMethods = [engine_method_type()]</v> + <v>Result = {ok, Engine::term()} | {error, Reason::term()}</v> + </type> + <desc> + <p> + Loads the OpenSSL engine given by <c>EngineId</c> if it is available and then returns ok and + an engine handle. An error tuple is returned if the engine can't be loaded. + </p> + <p> + The function throws a badarg if the parameters are in wrong format. + It may also throw the exception notsup in case there is + no engine support in the underlying OpenSSL implementation. + </p> + <p> + See also the chapter <seealso marker="crypto:engine_load#engine_load">Engine Load</seealso> + in the User's Guide. + </p> + </desc> + </func> + + <func> + <name>engine_unload(Engine) -> Result</name> + <fsummary>Dynamical load an encryption engine</fsummary> + <type> + <v>Engine = term()</v> + <v>Result = ok | {error, Reason::term()}</v> + </type> + <desc> + <p> + Unloads the OpenSSL engine given by <c>EngineId</c>. + An error tuple is returned if the engine can't be unloaded. + </p> + <p> + The function throws a badarg if the parameter is in wrong format. + It may also throw the exception notsup in case there is + no engine support in the underlying OpenSSL implementation. + </p> + <p> + See also the chapter <seealso marker="crypto:engine_load#engine_load">Engine Load</seealso> + in the User's Guide. + </p> + </desc> + </func> + + <func> + <name>engine_list() -> Result</name> + <fsummary>List the known engine ids</fsummary> + <type> + <v>Result = [EngineId::unicode:chardata()]</v> + </type> + <desc> + <p>List the id's of all engines in OpenSSL's internal list.</p> + <p> + It may also throw the exception notsup in case there is + no engine support in the underlying OpenSSL implementation. + </p> + <p> + See also the chapter <seealso marker="crypto:engine_load#engine_load">Engine Load</seealso> + in the User's Guide. + </p> + </desc> + </func> + + <func> + <name>engine_ctrl_cmd_string(Engine, CmdName, CmdArg) -> Result</name> + <fsummary>Sends ctrl commands to an OpenSSL engine</fsummary> + <type> + <v>Engine = term()</v> + <v>CmdName = unicode:chardata()</v> + <v>CmdArg = unicode:chardata()</v> + <v>Result = ok | {error, Reason::term()}</v> + </type> + <desc> + <p> + Sends ctrl commands to the OpenSSL engine given by <c>Engine</c>. + This function is the same as calling <c>engine_ctrl_cmd_string/4</c> with + <c>Optional</c> set to <c>false</c>. + </p> + <p> + The function throws a badarg if the parameters are in wrong format. + It may also throw the exception notsup in case there is + no engine support in the underlying OpenSSL implementation. + </p> + </desc> + </func> + + <func> + <name>engine_ctrl_cmd_string(Engine, CmdName, CmdArg, Optional) -> Result</name> + <fsummary>Sends ctrl commands to an OpenSSL engine</fsummary> + <type> + <v>Engine = term()</v> + <v>CmdName = unicode:chardata()</v> + <v>CmdArg = unicode:chardata()</v> + <v>Optional = boolean()</v> + <v>Result = ok | {error, Reason::term()}</v> + </type> + <desc> + <p> + Sends ctrl commands to the OpenSSL engine given by <c>Engine</c>. + <c>Optional</c> is a boolean argument that can relax the semantics of the function. + If set to <c>true</c> it will only return failure if the ENGINE supported the given + command name but failed while executing it, if the ENGINE doesn't support the command + name it will simply return success without doing anything. In this case we assume + the user is only supplying commands specific to the given ENGINE so we set this to + <c>false</c>. + </p> + <p> + The function throws a badarg if the parameters are in wrong format. + It may also throw the exception notsup in case there is + no engine support in the underlying OpenSSL implementation. + </p> + </desc> + </func> + </funcs> <!-- Maybe put this in the users guide --> @@ -1100,4 +1306,3 @@ _FloatValue = rand:uniform(). % [0.0; 1.0[</pre> <!-- </p> --> <!-- </section> --> </erlref> - diff --git a/lib/crypto/doc/src/engine_keys.xml b/lib/crypto/doc/src/engine_keys.xml new file mode 100644 index 0000000000..38714fed8a --- /dev/null +++ b/lib/crypto/doc/src/engine_keys.xml @@ -0,0 +1,129 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE chapter SYSTEM "chapter.dtd"> + +<chapter> + <header> + <copyright> + <year>2017</year><year>2017</year> + <holder>Ericsson AB. All Rights Reserved.</holder> + </copyright> + <legalnotice> + The contents of this file are subject to the Erlang Public License, + Version 1.1, (the "License"); you may not use this file except in + compliance with the License. You should have received a copy of the + Erlang Public License along with this software. If not, it can be + retrieved online at http://www.erlang.org/. + + Software distributed under the License is distributed on an "AS IS" + basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + the License for the specific language governing rights and limitations + under the License. + </legalnotice> + <title>Engine Stored Keys</title> + <prepared>Hans Nilsson</prepared> + <date>2017-11-10</date> + <file>engine_keys.xml</file> + </header> + <p> + <marker id="engine_key"></marker> + This chapter describes the support in the crypto application for using public and private keys stored in encryption engines. + </p> + + <section> + <title>Background</title> + <p> + <url href="https://www.openssl.org/">OpenSSL</url> exposes an Engine API, which makes + it possible to plug in alternative implementations for some of the cryptographic + operations implemented by OpenSSL. + See the chapter <seealso marker="crypto:engine_load#engine_load">Engine Load</seealso> + for details and how to load an Engine. + </p> + <p> + An engine could among other tasks provide a storage for + private or public keys. Such a storage could be made safer than the normal file system. Thoose techniques are not + described in this User's Guide. Here we concentrate on how to use private or public keys stored in + such an engine. + </p> + <p> + The storage engine must call <c>ENGINE_set_load_privkey_function</c> and <c>ENGINE_set_load_pubkey_function</c>. + See the OpenSSL cryptolib's <url href="https://www.openssl.org/docs/manpages.html">manpages</url>. + </p> + <p> + OTP/Crypto requires that the user provides two or three items of information about the key. The application used + by the user is usually on a higher level, for example in + <seealso marker="ssl:ssl#key_option_def">SSL</seealso>. If using + the crypto application directly, it is required that: + </p> + <list> + <item>an Engine is loaded, see the chapter on <seealso marker="crypto:engine_load#engine_load">Engine Load</seealso> + or the <seealso marker="crypto:crypto#engine_load-3">Reference Manual</seealso> + </item> + <item>a reference to a key in the Engine is available. This should be an Erlang string or binary and depends + on the Engine loaded + </item> + <item>an Erlang map is constructed with the Engine reference, the key reference and possibly a key passphrase if + needed by the Engine. See the <seealso marker="crypto:crypto#engine_key_ref_type">Reference Manual</seealso> for + details of the map. + </item> + </list> + </section> + + <section> + <title>Use Cases</title> + <section> + <title>Sign with an engine stored private key</title> + <p> + This example shows how to construct a key reference that is used in a sign operation. + The actual key is stored in the engine that is loaded at prompt 1. + </p> + <code> +1> {ok, EngineRef} = crypto:engine_load(....). +... +{ok,#Ref<0.2399045421.3028942852.173962>} +2> PrivKey = #{engine => EngineRef, + key_id => "id of the private key in Engine"}. +... +3> Signature = crypto:sign(rsa, sha, <<"The message">>, PrivKey). +<<65,6,125,254,54,233,84,77,83,63,168,28,169,214,121,76, + 207,177,124,183,156,185,160,243,36,79,125,230,231,...>> + </code> + </section> + + <section> + <title>Verify with an engine stored public key</title> + <p> + Here the signature and message in the last example is verifyed using the public key. + The public key is stored in an engine, only to exemplify that it is possible. The public + key could of course be handled openly as usual. + </p> + <code> +4> PublicKey = #{engine => EngineRef, + key_id => "id of the public key in Engine"}. +... +5> crypto:verify(rsa, sha, <<"The message">>, Signature, PublicKey). +true +6> + </code> + </section> + + <section> + <title>Using a password protected private key</title> + <p> + The same example as the first sign example, except that a password protects the key down in the Engine. + </p> + <code> +6> PrivKeyPwd = #{engine => EngineRef, + key_id => "id of the pwd protected private key in Engine", + password => "password"}. +... +7> crypto:sign(rsa, sha, <<"The message">>, PrivKeyPwd). +<<140,80,168,101,234,211,146,183,231,190,160,82,85,163, + 175,106,77,241,141,120,72,149,181,181,194,154,175,76, + 223,...>> +8> + </code> + + </section> + + </section> +</chapter> diff --git a/lib/crypto/doc/src/engine_load.xml b/lib/crypto/doc/src/engine_load.xml new file mode 100644 index 0000000000..e5c3f5d561 --- /dev/null +++ b/lib/crypto/doc/src/engine_load.xml @@ -0,0 +1,110 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE chapter SYSTEM "chapter.dtd"> + +<chapter> + <header> + <copyright> + <year>2017</year><year>2017</year> + <holder>Ericsson AB. All Rights Reserved.</holder> + </copyright> + <legalnotice> + The contents of this file are subject to the Erlang Public License, + Version 1.1, (the "License"); you may not use this file except in + compliance with the License. You should have received a copy of the + Erlang Public License along with this software. If not, it can be + retrieved online at http://www.erlang.org/. + + Software distributed under the License is distributed on an "AS IS" + basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + the License for the specific language governing rights and limitations + under the License. + </legalnotice> + <title>Engine Load</title> + <prepared>Lars Thorsén</prepared> + <date>2017-08-22</date> + <file>engine_load.xml</file> + </header> + <p> + <marker id="engine_load"></marker> + This chapter describes the support for loading encryption engines in the crypto application. + </p> + + <section> + <title>Background</title> + <p> + OpenSSL exposes an Engine API, which makes it possible to plug in alternative + implementations for some or all of the cryptographic operations implemented by OpenSSL. + When configured appropriately, OpenSSL calls the engine's implementation of these + operations instead of its own. + </p> + <p> + Typically, OpenSSL engines provide a hardware implementation of specific cryptographic + operations. The hardware implementation usually offers improved performance over its + software-based counterpart, which is known as cryptographic acceleration. + </p> + </section> + + <section> + <title>Use Cases</title> + <section> + <title>Dynamically load an engine from default directory</title> + <p> + If the engine is located in the OpenSSL/LibreSSL installation <c>engines</c> directory. + </p> + <code> +1> {ok, Engine} = crypto:engine_load(<<"otp_test_engine">>, [], []). + {ok, #Ref}</code> + <note> + <p>The file name requirement on the engine dynamic library can differ between SSL versions.</p> + </note> + </section> + + <section> + <title>Load an engine with the dynamic engine</title> + <p> + Load an engine with the help of the dynamic engine by giving the path to the library. + </p> + <code> + 2> {ok, Engine} = crypto:engine_load(<<"dynamic">>, + [{<<"SO_PATH">>, + <<"/some/path/otp_test_engine.so">>}, + {<<"ID">>, <<"MD5">>}, + <<"LOAD">>], + []). + {ok, #Ref}</code> + <note> + <p>The dynamic engine is not supported in LibreSSL from version 2.2.1</p> + </note> + </section> + + <section> + <title>Load an engine and replace some methods</title> + <p> + Load an engine with the help of the dynamic engine and just + replace some engine methods. + </p> + <code> + 3> Methods = crypto:engine_get_all_methods() -- [engine_method_dh,engine_method_rand, +engine_method_ciphers,engine_method_digests, engine_method_store, +engine_method_pkey_meths, engine_method_pkey_asn1_meths]. +[engine_method_rsa,engine_method_dsa, + engine_method_ecdh,engine_method_ecdsa] + 4> {ok, Engine} = crypto:engine_load(<<"dynamic">>, + [{<<"SO_PATH">>, + <<"/some/path/otp_test_engine.so">>}, + {<<"ID">>, <<"MD5">>}, + <<"LOAD">>], + [], + Methods). + {ok, #Ref}</code> + </section> + + <section> + <title>List all engines currently loaded</title> + <code> + 5> crypto:engine_list(). +[<<"dynamic">>, <<"MD5">>]</code> + </section> + + </section> +</chapter> diff --git a/lib/crypto/doc/src/notes.xml b/lib/crypto/doc/src/notes.xml index 9376e6f649..dbeb886d7b 100644 --- a/lib/crypto/doc/src/notes.xml +++ b/lib/crypto/doc/src/notes.xml @@ -31,6 +31,76 @@ </header> <p>This document describes the changes made to the Crypto application.</p> +<section><title>Crypto 4.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + The compatibility function <c>void HMAC_CTX_free</c> in + <c>crypto.c</c> erroneously tried to return a value.</p> + <p> + Own Id: OTP-14720</p> + </item> + </list> + </section> + + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + Rewrite public and private key encode/decode with EVP + api. New RSA padding options added. This is a modified + half of PR-838.</p> + <p> + Own Id: OTP-14446</p> + </item> + <item> + <p> + The crypto API is extended to use private/public keys + stored in an Engine for sign/verify or encrypt/decrypt + operations.</p> + <p> + The ssl application provides an API to use this new + engine concept in TLS.</p> + <p> + Own Id: OTP-14448</p> + </item> + <item> + <p> Add support to plug in alternative implementations + for some or all of the cryptographic operations supported + by the OpenSSL Engine API. When configured appropriately, + OpenSSL calls the engine's implementation of these + operations instead of its own. </p> + <p> + Own Id: OTP-14567</p> + </item> + <item> + <p> + Replaced a call of the OpenSSL deprecated function + <c>DH_generate_parameters</c> in <c>crypto.c</c>.</p> + <p> + Own Id: OTP-14639</p> + </item> + <item> + <p> + Documentation added about how to use keys stored in an + Engine.</p> + <p> + Own Id: OTP-14735 Aux Id: OTP-14448 </p> + </item> + <item> + <p> Add engine_ ctrl_cmd_string/3,4 the OpenSSL Engine + support in crypto. </p> + <p> + Own Id: OTP-14801</p> + </item> + </list> + </section> + +</section> + <section><title>Crypto 4.1</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/crypto/doc/src/usersguide.xml b/lib/crypto/doc/src/usersguide.xml index 7971aefff4..e2ba1fe160 100644 --- a/lib/crypto/doc/src/usersguide.xml +++ b/lib/crypto/doc/src/usersguide.xml @@ -11,7 +11,7 @@ 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 @@ -19,7 +19,7 @@ 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>Crypto User's Guide</title> @@ -48,5 +48,6 @@ </description> <xi:include href="licenses.xml"/> <xi:include href="fips.xml"/> + <xi:include href="engine_load.xml"/> + <xi:include href="engine_keys.xml"/> </part> - diff --git a/lib/crypto/src/Makefile b/lib/crypto/src/Makefile index aea8a5a71c..edad0e6b61 100644 --- a/lib/crypto/src/Makefile +++ b/lib/crypto/src/Makefile @@ -39,8 +39,7 @@ MODULES= \ crypto \ crypto_ec_curves -HRL_FILES= - +HRL_FILES= ERL_FILES= $(MODULES:%=%.erl) TARGET_FILES= $(MODULES:%=$(EBIN)/%.$(EMULATOR)) @@ -56,16 +55,16 @@ APPUP_TARGET= $(EBIN)/$(APPUP_FILE) # ---------------------------------------------------- # FLAGS # ---------------------------------------------------- -ERL_COMPILE_FLAGS += -DCRYPTO_VSN=\"$(VSN)\" -Werror +ERL_COMPILE_FLAGS += -DCRYPTO_VSN=\"$(VSN)\" -Werror -I../include # ---------------------------------------------------- # Targets # ---------------------------------------------------- -debug opt valgrind: $(TARGET_FILES) $(APP_TARGET) $(APPUP_TARGET) +debug opt valgrind: $(TARGET_FILES) $(APP_TARGET) $(APPUP_TARGET) clean: - rm -f $(TARGET_FILES) $(APP_TARGET) $(APPUP_TARGET) + rm -f $(TARGET_FILES) $(APP_TARGET) $(APPUP_TARGET) rm -f errs core *~ $(APP_TARGET): $(APP_SRC) ../vsn.mk @@ -78,7 +77,7 @@ docs: # ---------------------------------------------------- # Release Target -# ---------------------------------------------------- +# ---------------------------------------------------- include $(ERL_TOP)/make/otp_release_targets.mk release_spec: opt @@ -89,10 +88,3 @@ release_spec: opt $(APPUP_TARGET) "$(RELSYSDIR)/ebin" release_docs_spec: - - - - - - - diff --git a/lib/crypto/src/crypto.erl b/lib/crypto/src/crypto.erl index 6b4f3a256d..df259d5419 100644 --- a/lib/crypto/src/crypto.erl +++ b/lib/crypto/src/crypto.erl @@ -43,12 +43,28 @@ -export([public_encrypt/4, private_decrypt/4]). -export([private_encrypt/4, public_decrypt/4]). -export([dh_generate_parameters/2, dh_check/1]). %% Testing see +-export([privkey_to_pubkey/2]). -export([ec_curve/1, ec_curves/0]). -export([rand_seed/1]). +%% Engine +-export([ + engine_get_all_methods/0, + engine_load/3, + engine_load/4, + engine_unload/1, + engine_list/0, + engine_ctrl_cmd_string/3, + engine_ctrl_cmd_string/4 + ]). + +-export_type([engine_ref/0, + key_id/0, + password/0 + ]). -%% Private. For tests. --export([packed_openssl_version/4]). +%% Private. For tests. +-export([packed_openssl_version/4, engine_methods_convert_to_bitmask/2, get_test_engine/0]). -deprecated({rand_uniform, 2, next_major_release}). @@ -460,13 +476,24 @@ sign(Algorithm, Type, Data, Key, Options) -> end. + +-type key_id() :: string() | binary() . +-type password() :: string() | binary() . + +-type engine_key_ref() :: #{engine := engine_ref(), + key_id := key_id(), + password => password(), + term() => term() + }. + -type pk_algs() :: rsa | ecdsa | dss . --type pk_opt() :: list() | rsa_padding() . +-type pk_key() :: engine_key_ref() | [integer() | binary()] . +-type pk_opt() :: list() | rsa_padding() . --spec public_encrypt(pk_algs(), binary(), [binary()], pk_opt()) -> binary(). --spec public_decrypt(pk_algs(), binary(), [integer() | binary()], pk_opt()) -> binary(). --spec private_encrypt(pk_algs(), binary(), [integer() | binary()], pk_opt()) -> binary(). --spec private_decrypt(pk_algs(), binary(), [integer() | binary()], pk_opt()) -> binary(). +-spec public_encrypt(pk_algs(), binary(), pk_key(), pk_opt()) -> binary(). +-spec public_decrypt(pk_algs(), binary(), pk_key(), pk_opt()) -> binary(). +-spec private_encrypt(pk_algs(), binary(), pk_key(), pk_opt()) -> binary(). +-spec private_decrypt(pk_algs(), binary(), pk_key(), pk_opt()) -> binary(). public_encrypt(Algorithm, In, Key, Options) when is_list(Options) -> case pkey_crypt_nif(Algorithm, In, format_pkey(Algorithm, Key), Options, false, true) of @@ -607,10 +634,174 @@ compute_key(ecdh, Others, My, Curve) -> nif_curve_params(Curve), ensure_int_as_bin(My)). +%%====================================================================== +%% Engine functions +%%====================================================================== +%%---------------------------------------------------------------------- +%% Function: engine_get_all_methods/0 +%%---------------------------------------------------------------------- +-type engine_method_type() :: engine_method_rsa | engine_method_dsa | engine_method_dh | + engine_method_rand | engine_method_ecdh | engine_method_ecdsa | + engine_method_ciphers | engine_method_digests | engine_method_store | + engine_method_pkey_meths | engine_method_pkey_asn1_meths | + engine_method_ec. + +-type engine_ref() :: term(). + +-spec engine_get_all_methods() -> + [engine_method_type()]. +engine_get_all_methods() -> + notsup_to_error(engine_get_all_methods_nif()). + +%%---------------------------------------------------------------------- +%% Function: engine_load/3 +%%---------------------------------------------------------------------- +-spec engine_load(EngineId::unicode:chardata(), + PreCmds::[{unicode:chardata(), unicode:chardata()}], + PostCmds::[{unicode:chardata(), unicode:chardata()}]) -> + {ok, Engine::engine_ref()} | {error, Reason::term()}. +engine_load(EngineId, PreCmds, PostCmds) when is_list(PreCmds), is_list(PostCmds) -> + engine_load(EngineId, PreCmds, PostCmds, engine_get_all_methods()). + +%%---------------------------------------------------------------------- +%% Function: engine_load/4 +%%---------------------------------------------------------------------- +-spec engine_load(EngineId::unicode:chardata(), + PreCmds::[{unicode:chardata(), unicode:chardata()}], + PostCmds::[{unicode:chardata(), unicode:chardata()}], + EngineMethods::[engine_method_type()]) -> + {ok, Engine::term()} | {error, Reason::term()}. +engine_load(EngineId, PreCmds, PostCmds, EngineMethods) when is_list(PreCmds), + is_list(PostCmds) -> + try + ok = notsup_to_error(engine_load_dynamic_nif()), + case notsup_to_error(engine_by_id_nif(ensure_bin_chardata(EngineId))) of + {ok, Engine} -> + ok = engine_load_1(Engine, PreCmds, PostCmds, EngineMethods), + {ok, Engine}; + {error, Error1} -> + {error, Error1} + end + catch + throw:Error2 -> + Error2 + end. + +engine_load_1(Engine, PreCmds, PostCmds, EngineMethods) -> + try + ok = engine_nif_wrapper(engine_ctrl_cmd_strings_nif(Engine, ensure_bin_cmds(PreCmds), 0)), + ok = engine_nif_wrapper(engine_add_nif(Engine)), + ok = engine_nif_wrapper(engine_init_nif(Engine)), + engine_load_2(Engine, PostCmds, EngineMethods), + ok + catch + throw:Error -> + %% The engine couldn't initialise, release the structural reference + ok = engine_free_nif(Engine), + throw(Error) + end. + +engine_load_2(Engine, PostCmds, EngineMethods) -> + try + ok = engine_nif_wrapper(engine_ctrl_cmd_strings_nif(Engine, ensure_bin_cmds(PostCmds), 0)), + [ok = engine_nif_wrapper(engine_register_nif(Engine, engine_method_atom_to_int(Method))) || + Method <- EngineMethods], + ok + catch + throw:Error -> + %% The engine registration failed, release the functional reference + ok = engine_finish_nif(Engine), + throw(Error) + end. + +%%---------------------------------------------------------------------- +%% Function: engine_unload/1 +%%---------------------------------------------------------------------- +-spec engine_unload(Engine::term()) -> + ok | {error, Reason::term()}. +engine_unload(Engine) -> + engine_unload(Engine, engine_get_all_methods()). + +-spec engine_unload(Engine::term(), EngineMethods::[engine_method_type()]) -> + ok | {error, Reason::term()}. +engine_unload(Engine, EngineMethods) -> + try + [ok = engine_nif_wrapper(engine_unregister_nif(Engine, engine_method_atom_to_int(Method))) || + Method <- EngineMethods], + ok = engine_nif_wrapper(engine_remove_nif(Engine)), + %% Release the functional reference from engine_init_nif + ok = engine_nif_wrapper(engine_finish_nif(Engine)), + %% Release the structural reference from engine_by_id_nif + ok = engine_nif_wrapper(engine_free_nif(Engine)) + catch + throw:Error -> + Error + end. + +%%---------------------------------------------------------------------- +%% Function: engine_list/0 +%%---------------------------------------------------------------------- +-spec engine_list() -> + [EngineId::binary()]. +engine_list() -> + case notsup_to_error(engine_get_first_nif()) of + {ok, <<>>} -> + []; + {ok, Engine} -> + case notsup_to_error(engine_get_id_nif(Engine)) of + {ok, <<>>} -> + engine_list(Engine, []); + {ok, EngineId} -> + engine_list(Engine, [EngineId]) + end + end. + +engine_list(Engine0, IdList) -> + case notsup_to_error(engine_get_next_nif(Engine0)) of + {ok, <<>>} -> + lists:reverse(IdList); + {ok, Engine1} -> + case notsup_to_error(engine_get_id_nif(Engine1)) of + {ok, <<>>} -> + engine_list(Engine1, IdList); + {ok, EngineId} -> + engine_list(Engine1, [EngineId |IdList]) + end + end. + +%%---------------------------------------------------------------------- +%% Function: engine_ctrl_cmd_string/3 +%%---------------------------------------------------------------------- +-spec engine_ctrl_cmd_string(Engine::term(), + CmdName::unicode:chardata(), + CmdArg::unicode:chardata()) -> + ok | {error, Reason::term()}. +engine_ctrl_cmd_string(Engine, CmdName, CmdArg) -> + engine_ctrl_cmd_string(Engine, CmdName, CmdArg, false). + +%%---------------------------------------------------------------------- +%% Function: engine_ctrl_cmd_string/4 +%%---------------------------------------------------------------------- +-spec engine_ctrl_cmd_string(Engine::term(), + CmdName::unicode:chardata(), + CmdArg::unicode:chardata(), + Optional::boolean()) -> + ok | {error, Reason::term()}. +engine_ctrl_cmd_string(Engine, CmdName, CmdArg, Optional) -> + case engine_ctrl_cmd_strings_nif(Engine, + ensure_bin_cmds([{CmdName, CmdArg}]), + bool_to_int(Optional)) of + ok -> + ok; + notsup -> + erlang:error(notsup); + {error, Error} -> + {error, Error} + end. + %%-------------------------------------------------------------------- %%% On load %%-------------------------------------------------------------------- - on_load() -> LibBaseName = "crypto", PrivDir = code:priv_dir(crypto), @@ -670,12 +861,12 @@ path2bin(Path) when is_list(Path) -> end. %%-------------------------------------------------------------------- -%%% Internal functions +%%% Internal functions %%-------------------------------------------------------------------- max_bytes() -> ?MAX_BYTES_TO_NIF. -notsup_to_error(notsup) -> +notsup_to_error(notsup) -> erlang:error(notsup); notsup_to_error(Other) -> Other. @@ -799,7 +990,7 @@ do_stream_decrypt({rc4, State0}, Data) -> %% -%% AES - in counter mode (CTR) with state maintained for multi-call streaming +%% AES - in counter mode (CTR) with state maintained for multi-call streaming %% -type ctr_state() :: { iodata(), binary(), binary(), integer() } | binary(). @@ -808,11 +999,11 @@ do_stream_decrypt({rc4, State0}, Data) -> { ctr_state(), binary() }. -spec aes_ctr_stream_decrypt(ctr_state(), binary()) -> { ctr_state(), binary() }. - + aes_ctr_stream_init(_Key, _IVec) -> ?nif_stub. aes_ctr_stream_encrypt(_State, _Data) -> ?nif_stub. aes_ctr_stream_decrypt(_State, _Cipher) -> ?nif_stub. - + %% %% RC4 - symmetric stream cipher %% @@ -897,22 +1088,22 @@ pkey_verify_nif(_Algorithm, _Type, _Data, _Signature, _Key, _Options) -> ?nif_st rsa_generate_key_nif(_Bits, _Exp) -> ?nif_stub. %% DH Diffie-Hellman functions -%% +%% %% Generate (and check) Parameters is not documented because they are implemented %% for testing (and offline parameter generation) only. -%% From the openssl doc: +%% From the openssl doc: %% DH_generate_parameters() may run for several hours before finding a suitable prime. -%% Thus dh_generate_parameters may in this implementation block +%% Thus dh_generate_parameters may in this implementation block %% the emulator for several hours. %% -%% usage: dh_generate_parameters(1024, 2 or 5) -> +%% usage: dh_generate_parameters(1024, 2 or 5) -> %% [Prime=mpint(), SharedGenerator=mpint()] dh_generate_parameters(PrimeLen, Generator) -> case dh_generate_parameters_nif(PrimeLen, Generator) of error -> erlang:error(generation_failed, [PrimeLen,Generator]); Ret -> Ret - end. + end. dh_generate_parameters_nif(_PrimeLen, _Generator) -> ?nif_stub. @@ -938,6 +1129,24 @@ ec_curves() -> ec_curve(X) -> crypto_ec_curves:curve(X). + +privkey_to_pubkey(Alg, EngineMap) when Alg == rsa; Alg == dss; Alg == ecdsa -> + try privkey_to_pubkey_nif(Alg, format_pkey(Alg,EngineMap)) + of + [_|_]=L -> map_ensure_bin_as_int(L); + X -> X + catch + error:badarg when Alg==ecdsa -> + {error, notsup}; + error:badarg -> + {error, not_found}; + error:notsup -> + {error, notsup} + end. + +privkey_to_pubkey_nif(_Alg, _EngineMap) -> ?nif_stub. + + %% %% EC %% @@ -1005,6 +1214,19 @@ ensure_int_as_bin(Int) when is_integer(Int) -> ensure_int_as_bin(Bin) -> Bin. +map_ensure_bin_as_int(List) when is_list(List) -> + lists:map(fun ensure_bin_as_int/1, List). + +ensure_bin_as_int(Bin) when is_binary(Bin) -> + bin_to_int(Bin); +ensure_bin_as_int(E) -> + E. + +format_pkey(_Alg, #{engine:=_, key_id:=T}=M) when is_binary(T) -> format_pwd(M); +format_pkey(_Alg, #{engine:=_, key_id:=T}=M) when is_list(T) -> format_pwd(M#{key_id:=list_to_binary(T)}); +format_pkey(_Alg, #{engine:=_ }=M) -> error({bad_key_id, M}); +format_pkey(_Alg, #{}=M) -> error({bad_engine_map, M}); +%%% format_pkey(rsa, Key) -> map_ensure_int_as_bin(Key); format_pkey(ecdsa, [Key, Curve]) -> @@ -1014,6 +1236,9 @@ format_pkey(dss, Key) -> format_pkey(_, Key) -> Key. +format_pwd(#{password := Pwd}=M) when is_list(Pwd) -> M#{password := list_to_binary(Pwd)}; +format_pwd(M) -> M. + %%-------------------------------------------------------------------- %% -type rsa_padding() :: 'rsa_pkcs1_padding' | 'rsa_pkcs1_oaep_padding' | 'rsa_no_padding'. @@ -1024,7 +1249,7 @@ pkey_crypt_nif(_Algorithm, _In, _Key, _Options, _IsPrivate, _IsEncrypt) -> ?nif_ %% MP representaion (SSH2) mpint(X) when X < 0 -> mpint_neg(X); mpint(X) -> mpint_pos(X). - + -define(UINT32(X), X:32/unsigned-big-integer). @@ -1032,7 +1257,7 @@ mpint_neg(X) -> Bin = int_to_bin_neg(X, []), Sz = byte_size(Bin), <<?UINT32(Sz), Bin/binary>>. - + mpint_pos(X) -> Bin = int_to_bin_pos(X, []), <<MSB,_/binary>> = Bin, @@ -1054,7 +1279,6 @@ erlint(<<MPIntSize:32/integer,MPIntValue/binary>>) -> %% mod_exp_nif(_Base,_Exp,_Mod,_bin_hdr) -> ?nif_stub. - %%%---------------------------------------------------------------- %% 9470495 == V(0,9,8,zh). %% 268435615 == V(1,0,0,i). @@ -1065,3 +1289,95 @@ packed_openssl_version(MAJ, MIN, FIX, P0) -> P1 = atom_to_list(P0), P = lists:sum([C-$a||C<-P1]), ((((((((MAJ bsl 8) bor MIN) bsl 8 ) bor FIX) bsl 8) bor (P+1)) bsl 4) bor 16#f). + +%%-------------------------------------------------------------------- +%% Engine nifs +engine_by_id_nif(_EngineId) -> ?nif_stub. +engine_init_nif(_Engine) -> ?nif_stub. +engine_finish_nif(_Engine) -> ?nif_stub. +engine_free_nif(_Engine) -> ?nif_stub. +engine_load_dynamic_nif() -> ?nif_stub. +engine_ctrl_cmd_strings_nif(_Engine, _Cmds, _Optional) -> ?nif_stub. +engine_add_nif(_Engine) -> ?nif_stub. +engine_remove_nif(_Engine) -> ?nif_stub. +engine_register_nif(_Engine, _EngineMethod) -> ?nif_stub. +engine_unregister_nif(_Engine, _EngineMethod) -> ?nif_stub. +engine_get_first_nif() -> ?nif_stub. +engine_get_next_nif(_Engine) -> ?nif_stub. +engine_get_id_nif(_Engine) -> ?nif_stub. +engine_get_all_methods_nif() -> ?nif_stub. + +%%-------------------------------------------------------------------- +%% Engine internals +engine_nif_wrapper(ok) -> + ok; +engine_nif_wrapper(notsup) -> + erlang:error(notsup); +engine_nif_wrapper({error, Error}) -> + throw({error, Error}). + +ensure_bin_chardata(CharData) when is_binary(CharData) -> + CharData; +ensure_bin_chardata(CharData) -> + unicode:characters_to_binary(CharData). + +ensure_bin_cmds(CMDs) -> + ensure_bin_cmds(CMDs, []). + +ensure_bin_cmds([], Acc) -> + lists:reverse(Acc); +ensure_bin_cmds([{Key, Value} |CMDs], Acc) -> + ensure_bin_cmds(CMDs, [{ensure_bin_chardata(Key), ensure_bin_chardata(Value)} | Acc]); +ensure_bin_cmds([Key | CMDs], Acc) -> + ensure_bin_cmds(CMDs, [{ensure_bin_chardata(Key), <<"">>} | Acc]). + +engine_methods_convert_to_bitmask([], BitMask) -> + BitMask; +engine_methods_convert_to_bitmask(engine_method_all, _BitMask) -> + 16#FFFF; +engine_methods_convert_to_bitmask(engine_method_none, _BitMask) -> + 16#0000; +engine_methods_convert_to_bitmask([M |Ms], BitMask) -> + engine_methods_convert_to_bitmask(Ms, BitMask bor engine_method_atom_to_int(M)). + +bool_to_int(true) -> 1; +bool_to_int(false) -> 0. + +engine_method_atom_to_int(engine_method_rsa) -> 16#0001; +engine_method_atom_to_int(engine_method_dsa) -> 16#0002; +engine_method_atom_to_int(engine_method_dh) -> 16#0004; +engine_method_atom_to_int(engine_method_rand) -> 16#0008; +engine_method_atom_to_int(engine_method_ecdh) -> 16#0010; +engine_method_atom_to_int(engine_method_ecdsa) -> 16#0020; +engine_method_atom_to_int(engine_method_ciphers) -> 16#0040; +engine_method_atom_to_int(engine_method_digests) -> 16#0080; +engine_method_atom_to_int(engine_method_store) -> 16#0100; +engine_method_atom_to_int(engine_method_pkey_meths) -> 16#0200; +engine_method_atom_to_int(engine_method_pkey_asn1_meths) -> 16#0400; +engine_method_atom_to_int(engine_method_ec) -> 16#0800; +engine_method_atom_to_int(X) -> + erlang:error(badarg, [X]). + +get_test_engine() -> + Type = erlang:system_info(system_architecture), + LibDir = filename:join([code:priv_dir(crypto), "lib"]), + ArchDir = filename:join([LibDir, Type]), + case filelib:is_dir(ArchDir) of + true -> check_otp_test_engine(ArchDir); + false -> check_otp_test_engine(LibDir) + end. + +check_otp_test_engine(LibDir) -> + case filelib:wildcard("otp_test_engine*", LibDir) of + [] -> + {error, notexist}; + [LibName] -> + LibPath = filename:join(LibDir,LibName), + case filelib:is_file(LibPath) of + true -> + {ok, unicode:characters_to_binary(LibPath)}; + false -> + {error, notexist} + end + end. + diff --git a/lib/crypto/test/Makefile b/lib/crypto/test/Makefile index 138081d386..e046a25338 100644 --- a/lib/crypto/test/Makefile +++ b/lib/crypto/test/Makefile @@ -7,7 +7,8 @@ include $(ERL_TOP)/make/$(TARGET)/otp.mk MODULES = \ blowfish_SUITE \ - crypto_SUITE + crypto_SUITE \ + engine_SUITE ERL_FILES= $(MODULES:%=%.erl) @@ -27,7 +28,7 @@ RELSYSDIR = $(RELEASE_PATH)/crypto_test # FLAGS # ---------------------------------------------------- ERL_MAKE_FLAGS += -ERL_COMPILE_FLAGS += +ERL_COMPILE_FLAGS += +nowarn_export_all EBIN = . MAKE_EMAKE = $(wildcard $(ERL_TOP)/make/make_emakefile) @@ -77,7 +78,7 @@ release_spec: release_tests_spec: $(TEST_TARGET) $(INSTALL_DIR) "$(RELSYSDIR)" $(INSTALL_DATA) crypto.spec crypto.cover $(RELTEST_FILES) "$(RELSYSDIR)" - @tar cfh - crypto_SUITE_data | (cd "$(RELSYSDIR)"; tar xf -) + @tar cfh - *_SUITE_data | (cd "$(RELSYSDIR)"; tar xf -) chmod -R u+w "$(RELSYSDIR)" release_docs_spec: diff --git a/lib/crypto/test/crypto_SUITE.erl b/lib/crypto/test/crypto_SUITE.erl index 69f02d3da6..6dab459df6 100644 --- a/lib/crypto/test/crypto_SUITE.erl +++ b/lib/crypto/test/crypto_SUITE.erl @@ -198,7 +198,7 @@ init_per_suite(Config) -> %% This is NOT how you want to do seeding, it is just here %% to make the tests pass. Check your OS manual for how you %% really want to seed. - {H,M,L} = erlang:now(), + {H,M,L} = erlang:timestamp(), Bin = <<H:24,M:20,L:20>>, crypto:rand_seed(<< <<Bin/binary>> || _ <- lists:seq(1,16) >>), Config diff --git a/lib/crypto/test/engine_SUITE.erl b/lib/crypto/test/engine_SUITE.erl new file mode 100644 index 0000000000..f206f967c7 --- /dev/null +++ b/lib/crypto/test/engine_SUITE.erl @@ -0,0 +1,660 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017-2017. 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(engine_SUITE). + +-include_lib("common_test/include/ct.hrl"). + +%% Note: This directive should only be used in test suites. +-compile(export_all). + +%%-------------------------------------------------------------------- +%% Common Test interface functions ----------------------------------- +%%-------------------------------------------------------------------- +suite() -> + [{ct_hooks,[ts_install_cth]}, + {timetrap,{seconds, 10}} + ]. + +all() -> + [ + get_all_possible_methods, + engine_load_all_methods, + engine_load_some_methods, + bad_arguments, + unknown_engine, + pre_command_fail_bad_value, + pre_command_fail_bad_key, + failed_engine_init, + ctrl_cmd_string, + ctrl_cmd_string_optional, + {group, engine_stored_key} + ]. + +groups() -> + [{engine_stored_key, [], + [sign_verify_rsa, + sign_verify_dsa, + sign_verify_ecdsa, + sign_verify_rsa_pwd, + sign_verify_rsa_pwd_bad_pwd, + priv_encrypt_pub_decrypt_rsa, + priv_encrypt_pub_decrypt_rsa_pwd, + pub_encrypt_priv_decrypt_rsa, + pub_encrypt_priv_decrypt_rsa_pwd, + get_pub_from_priv_key_rsa, + get_pub_from_priv_key_rsa_pwd, + get_pub_from_priv_key_rsa_pwd_no_pwd, + get_pub_from_priv_key_rsa_pwd_bad_pwd, + get_pub_from_priv_key_dsa, + get_pub_from_priv_key_ecdsa + ]}]. + + +init_per_suite(Config) -> + try crypto:start() of + ok -> + Config; + {error,{already_started,crypto}} -> + Config + catch _:_ -> + {skip, "Crypto did not start"} + end. +end_per_suite(_Config) -> + ok. + +%%-------------------------------------------------------------------- +init_per_group(engine_stored_key, Config) -> + case load_storage_engine(Config) of + {ok, E} -> + KeyDir = key_dir(Config), + [{storage_engine,E}, {storage_dir,KeyDir} | Config]; + {error, notexist} -> + {skip, "OTP Test engine not found"}; + {error, notsup} -> + {skip, "Engine not supported on this OpenSSL version"}; + {error, bad_engine_id} -> + {skip, "Dynamic Engine not supported"}; + Other -> + ct:log("Engine load failed: ~p",[Other]), + {fail, "Engine load failed"} + end; +init_per_group(_Group, Config0) -> + Config0. + +end_per_group(engine_stored_key, Config) -> + case proplists:get_value(storage_engine, Config) of + undefined -> + ok; + E -> + ok = crypto:engine_unload(E) + end; +end_per_group(_, _) -> + ok. + +%%-------------------------------------------------------------------- +init_per_testcase(_Case, Config) -> + Config. +end_per_testcase(_Case, _Config) -> + ok. + +%%------------------------------------------------------------------------- +%% Test cases starts here. +%%------------------------------------------------------------------------- +get_all_possible_methods() -> + [{doc, "Just fetch all possible engine methods supported."}]. + +get_all_possible_methods(Config) when is_list(Config) -> + try + List = crypto:engine_get_all_methods(), + ct:log("crypto:engine_get_all_methods() -> ~p\n", [List]), + ok + catch + error:notsup -> + {skip, "Engine not supported on this OpenSSL version"} + end. + +engine_load_all_methods()-> + [{doc, "Use a dummy md5 engine that does not implement md5" + "but rather returns a static binary to test that crypto:engine_load " + "functions works."}]. + +engine_load_all_methods(Config) when is_list(Config) -> + case crypto:get_test_engine() of + {error, notexist} -> + {skip, "OTP Test engine not found"}; + {ok, Engine} -> + try + Md5Hash1 = <<106,30,3,246,166,222,229,158,244,217,241,179,50,232,107,109>>, + Md5Hash1 = crypto:hash(md5, "Don't panic"), + Md5Hash2 = <<0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15>>, + case crypto:engine_load(<<"dynamic">>, + [{<<"SO_PATH">>, Engine}, + {<<"ID">>, <<"MD5">>}, + <<"LOAD">>], + []) of + {ok, E} -> + case crypto:hash(md5, "Don't panic") of + Md5Hash1 -> + ct:fail(fail_to_load_still_original_engine); + Md5Hash2 -> + ok; + _ -> + ct:fail(fail_to_load_engine) + end, + ok = crypto:engine_unload(E), + case crypto:hash(md5, "Don't panic") of + Md5Hash2 -> + ct:fail(fail_to_unload_still_test_engine); + Md5Hash1 -> + ok; + _ -> + ct:fail(fail_to_unload_engine) + end; + {error, bad_engine_id} -> + {skip, "Dynamic Engine not supported"} + end + catch + error:notsup -> + {skip, "Engine not supported on this OpenSSL version"} + end + end. + +engine_load_some_methods()-> + [{doc, "Use a dummy md5 engine that does not implement md5" + "but rather returns a static binary to test that crypto:engine_load " + "functions works."}]. + +engine_load_some_methods(Config) when is_list(Config) -> + case crypto:get_test_engine() of + {error, notexist} -> + {skip, "OTP Test engine not found"}; + {ok, Engine} -> + try + Md5Hash1 = <<106,30,3,246,166,222,229,158,244,217,241,179,50,232,107,109>>, + Md5Hash1 = crypto:hash(md5, "Don't panic"), + Md5Hash2 = <<0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15>>, + EngineMethods = crypto:engine_get_all_methods() -- + [engine_method_dh,engine_method_rand, + engine_method_ciphers, engine_method_store, + engine_method_pkey_meths, engine_method_pkey_asn1_meths], + case crypto:engine_load(<<"dynamic">>, + [{<<"SO_PATH">>, Engine}, + {<<"ID">>, <<"MD5">>}, + <<"LOAD">>], + [], + EngineMethods) of + {ok, E} -> + case crypto:hash(md5, "Don't panic") of + Md5Hash1 -> + ct:fail(fail_to_load_engine_still_original); + Md5Hash2 -> + ok; + _ -> + ct:fail(fail_to_load_engine) + end, + ok = crypto:engine_unload(E), + case crypto:hash(md5, "Don't panic") of + Md5Hash2 -> + ct:fail(fail_to_unload_still_test_engine); + Md5Hash1 -> + ok; + _ -> + ct:fail(fail_to_unload_engine) + end; + {error, bad_engine_id} -> + {skip, "Dynamic Engine not supported"} + end + catch + error:notsup -> + {skip, "Engine not supported on this OpenSSL version"} + end + end. + +%%------------------------------------------------------------------------- +%% Error cases +bad_arguments()-> + [{doc, "Test different arguments in bad format."}]. + +bad_arguments(Config) when is_list(Config) -> + case crypto:get_test_engine() of + {error, notexist} -> + {skip, "OTP Test engine not found"}; + {ok, Engine} -> + try + try + crypto:engine_load(fail_engine, [], []) + catch + error:badarg -> + ok + end, + try + crypto:engine_load(<<"dynamic">>, + [{<<"SO_PATH">>, Engine}, + 1, + {<<"ID">>, <<"MD5">>}, + <<"LOAD">>], + []) + catch + error:badarg -> + ok + end, + try + crypto:engine_load(<<"dynamic">>, + [{<<"SO_PATH">>, Engine}, + {'ID', <<"MD5">>}, + <<"LOAD">>], + []) + catch + error:badarg -> + ok + end + catch + error:notsup -> + {skip, "Engine not supported on this OpenSSL version"} + end + end. + +unknown_engine() -> + [{doc, "Try to load a non existent engine."}]. + +unknown_engine(Config) when is_list(Config) -> + try + {error, bad_engine_id} = crypto:engine_load(<<"fail_engine">>, [], []), + ok + catch + error:notsup -> + {skip, "Engine not supported on this OpenSSL version"} + end. + +pre_command_fail_bad_value() -> + [{doc, "Test pre command due to bad value"}]. + +pre_command_fail_bad_value(Config) when is_list(Config) -> + DataDir = unicode:characters_to_binary(code:priv_dir(crypto)), + try + case crypto:engine_load(<<"dynamic">>, + [{<<"SO_PATH">>, + <<DataDir/binary, <<"/libfail_engine.so">>/binary >>}, + {<<"ID">>, <<"MD5">>}, + <<"LOAD">>], + []) of + {error, ctrl_cmd_failed} -> + ok; + {error, bad_engine_id} -> + {skip, "Dynamic Engine not supported"} + end + catch + error:notsup -> + {skip, "Engine not supported on this OpenSSL version"} + end. + +pre_command_fail_bad_key() -> + [{doc, "Test pre command due to bad key"}]. + +pre_command_fail_bad_key(Config) when is_list(Config) -> + try + case crypto:get_test_engine() of + {error, notexist} -> + {skip, "OTP Test engine not found"}; + {ok, Engine} -> + case crypto:engine_load(<<"dynamic">>, + [{<<"SO_WRONG_PATH">>, Engine}, + {<<"ID">>, <<"MD5">>}, + <<"LOAD">>], + []) of + {error, ctrl_cmd_failed} -> + ok; + {error, bad_engine_id} -> + {skip, "Dynamic Engine not supported"} + end + end + catch + error:notsup -> + {skip, "Engine not supported on this OpenSSL version"} + end. + +failed_engine_init()-> + [{doc, "Test failing engine init due to missed pre command"}]. + +failed_engine_init(Config) when is_list(Config) -> + try + case crypto:get_test_engine() of + {error, notexist} -> + {skip, "OTP Test engine not found"}; + {ok, Engine} -> + case crypto:engine_load(<<"dynamic">>, + [{<<"SO_PATH">>, Engine}, + {<<"ID">>, <<"MD5">>}], + []) of + {error, add_engine_failed} -> + ok; + {error, bad_engine_id} -> + {skip, "Dynamic Engine not supported"} + end + end + catch + error:notsup -> + {skip, "Engine not supported on this OpenSSL version"} + end. + + +ctrl_cmd_string()-> + [{doc, "Test that a not known optional ctrl comand do not fail"}]. +ctrl_cmd_string(Config) when is_list(Config) -> + try + case crypto:get_test_engine() of + {error, notexist} -> + {skip, "OTP Test engine not found"}; + {ok, Engine} -> + case crypto:engine_load(<<"dynamic">>, + [{<<"SO_PATH">>, Engine}, + {<<"ID">>, <<"MD5">>}, + <<"LOAD">>], + []) of + {ok, E} -> + case crypto:engine_ctrl_cmd_string(E, <<"TEST">>, <<"17">>) of + ok -> + ct:fail(fail_ctrl_cmd_should_fail); + {error,ctrl_cmd_failed} -> + ok + end, + ok = crypto:engine_unload(E); + {error, bad_engine_id} -> + {skip, "Dynamic Engine not supported"} + end + end + catch + error:notsup -> + {skip, "Engine not supported on this OpenSSL version"} + end. + +ctrl_cmd_string_optional()-> + [{doc, "Test that a not known optional ctrl comand do not fail"}]. +ctrl_cmd_string_optional(Config) when is_list(Config) -> + try + case crypto:get_test_engine() of + {error, notexist} -> + {skip, "OTP Test engine not found"}; + {ok, Engine} -> + case crypto:engine_load(<<"dynamic">>, + [{<<"SO_PATH">>, Engine}, + {<<"ID">>, <<"MD5">>}, + <<"LOAD">>], + []) of + {ok, E} -> + case crypto:engine_ctrl_cmd_string(E, <<"TEST">>, <<"17">>, true) of + ok -> + ok; + _ -> + ct:fail(fail_ctrl_cmd_string) + end, + ok = crypto:engine_unload(E); + {error, bad_engine_id} -> + {skip, "Dynamic Engine not supported"} + end + end + catch + error:notsup -> + {skip, "Engine not supported on this OpenSSL version"} + end. + +%%%---------------------------------------------------------------- +%%% Pub/priv key storage tests. Thoose are for testing the crypto.erl +%%% support for using priv/pub keys stored in an engine. + +sign_verify_rsa(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_private_key.pem")}, + Pub = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_public_key.pem")}, + sign_verify(rsa, sha, Priv, Pub). + +sign_verify_dsa(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "dsa_private_key.pem")}, + Pub = #{engine => engine_ref(Config), + key_id => key_id(Config, "dsa_public_key.pem")}, + sign_verify(dss, sha, Priv, Pub). + +sign_verify_ecdsa(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "ecdsa_private_key.pem")}, + Pub = #{engine => engine_ref(Config), + key_id => key_id(Config, "ecdsa_public_key.pem")}, + sign_verify(ecdsa, sha, Priv, Pub). + +sign_verify_rsa_pwd(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_private_key_pwd.pem"), + password => "password"}, + Pub = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_public_key_pwd.pem")}, + sign_verify(rsa, sha, Priv, Pub). + +sign_verify_rsa_pwd_bad_pwd(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_private_key_pwd.pem"), + password => "Bad password"}, + Pub = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_public_key_pwd.pem")}, + try sign_verify(rsa, sha, Priv, Pub) of + _ -> {fail, "PWD prot pubkey sign succeded with no pwd!"} + catch + error:badarg -> ok + end. + +priv_encrypt_pub_decrypt_rsa(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_private_key.pem")}, + Pub = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_public_key.pem")}, + priv_enc_pub_dec(rsa, Priv, Pub, rsa_pkcs1_padding). + +priv_encrypt_pub_decrypt_rsa_pwd(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_private_key_pwd.pem"), + password => "password"}, + Pub = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_public_key_pwd.pem")}, + priv_enc_pub_dec(rsa, Priv, Pub, rsa_pkcs1_padding). + +pub_encrypt_priv_decrypt_rsa(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_private_key.pem")}, + Pub = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_public_key.pem")}, + pub_enc_priv_dec(rsa, Pub, Priv, rsa_pkcs1_padding). + +pub_encrypt_priv_decrypt_rsa_pwd(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_private_key_pwd.pem"), + password => "password"}, + Pub = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_public_key_pwd.pem")}, + pub_enc_priv_dec(rsa, Pub, Priv, rsa_pkcs1_padding). + +get_pub_from_priv_key_rsa(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_private_key.pem")}, + case crypto:privkey_to_pubkey(rsa, Priv) of + {error, not_found} -> + {fail, "Key not found"}; + {error, notsup} -> + {skip, "RSA not supported"}; + {error, Error} -> + {fail, {wrong_error,Error}}; + Pub -> + ct:log("rsa Pub = ~p",[Pub]), + sign_verify(rsa, sha, Priv, Pub) + end. + +get_pub_from_priv_key_rsa_pwd(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_private_key_pwd.pem"), + password => "password"}, + case crypto:privkey_to_pubkey(rsa, Priv) of + {error, not_found} -> + {fail, "Key not found"}; + {error, notsup} -> + {skip, "RSA not supported"}; + {error, Error} -> + {fail, {wrong_error,Error}}; + Pub -> + ct:log("rsa Pub = ~p",[Pub]), + sign_verify(rsa, sha, Priv, Pub) + end. + +get_pub_from_priv_key_rsa_pwd_no_pwd(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_private_key_pwd.pem")}, + case crypto:privkey_to_pubkey(rsa, Priv) of + {error, not_found} -> + ok; + {error, notsup} -> + {skip, "RSA not supported"}; + {error, Error} -> + {fail, {wrong_error,Error}}; + Pub -> + ct:log("rsa Pub = ~p",[Pub]), + {fail, "PWD prot pubkey fetch succeded although no pwd!"} + end. + +get_pub_from_priv_key_rsa_pwd_bad_pwd(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "rsa_private_key_pwd.pem"), + password => "Bad password"}, + case crypto:privkey_to_pubkey(rsa, Priv) of + {error, not_found} -> + ok; + {error, notsup} -> + {skip, "RSA not supported"}; + {error, Error} -> + {fail, {wrong_error,Error}}; + Pub -> + ct:log("rsa Pub = ~p",[Pub]), + {fail, "PWD prot pubkey fetch succeded with bad pwd!"} + end. + +get_pub_from_priv_key_dsa(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "dsa_private_key.pem")}, + case crypto:privkey_to_pubkey(dss, Priv) of + {error, not_found} -> + {fail, "Key not found"}; + {error, notsup} -> + {skip, "DSA not supported"}; + {error, Error} -> + {fail, {wrong_error,Error}}; + Pub -> + ct:log("dsa Pub = ~p",[Pub]), + sign_verify(dss, sha, Priv, Pub) + end. + +get_pub_from_priv_key_ecdsa(Config) -> + Priv = #{engine => engine_ref(Config), + key_id => key_id(Config, "ecdsa_private_key.pem")}, + case crypto:privkey_to_pubkey(ecdsa, Priv) of + {error, not_found} -> + {fail, "Key not found"}; + {error, notsup} -> + {skip, "ECDSA not supported"}; + {error, Error} -> + {fail, {wrong_error,Error}}; + Pub -> + ct:log("ecdsa Pub = ~p",[Pub]), + sign_verify(ecdsa, sha, Priv, Pub) + end. + +%%%================================================================ +%%% Help for engine_stored_pub_priv_keys* test cases +%%% +load_storage_engine(_Config) -> + case crypto:get_test_engine() of + {ok, Engine} -> + try crypto:engine_load(<<"dynamic">>, + [{<<"SO_PATH">>, Engine}, + <<"LOAD">>], + []) + catch + error:notsup -> + {error, notsup} + end; + + {error, Error} -> + {error, Error} + end. + + +key_dir(Config) -> + DataDir = unicode:characters_to_binary(proplists:get_value(data_dir, Config)), + filename:join(DataDir, "pkcs8"). + + +engine_ref(Config) -> + proplists:get_value(storage_engine, Config). + +key_id(Config, File) -> + filename:join(proplists:get_value(storage_dir,Config), File). + +pubkey_alg_supported(Alg) -> + lists:member(Alg, + proplists:get_value(public_keys, crypto:supports())). + + +pub_enc_priv_dec(Alg, KeyEnc, KeyDec, Padding) -> + case pubkey_alg_supported(Alg) of + true -> + PlainText = <<"Hej på dig">>, + CryptoText = crypto:public_encrypt(Alg, PlainText, KeyEnc, Padding), + case crypto:private_decrypt(Alg, CryptoText, KeyDec, Padding) of + PlainText -> ok; + _ -> {fail, "Encrypt-decrypt error"} + end; + false -> + {skip, lists:concat([Alg," is not supported by cryptolib"])} + end. + +priv_enc_pub_dec(Alg, KeyEnc, KeyDec, Padding) -> + case pubkey_alg_supported(Alg) of + true -> + PlainText = <<"Hej på dig">>, + CryptoText = crypto:private_encrypt(Alg, PlainText, KeyEnc, Padding), + case crypto:public_decrypt(Alg, CryptoText, KeyDec, Padding) of + PlainText -> ok; + _ -> {fail, "Encrypt-decrypt error"} + end; + false -> + {skip, lists:concat([Alg," is not supported by cryptolib"])} + end. + +sign_verify(Alg, Sha, KeySign, KeyVerify) -> + case pubkey_alg_supported(Alg) of + true -> + PlainText = <<"Hej på dig">>, + Signature = crypto:sign(Alg, Sha, PlainText, KeySign), + case crypto:verify(Alg, Sha, PlainText, Signature, KeyVerify) of + true -> ok; + _ -> {fail, "Sign-verify error"} + end; + false -> + {skip, lists:concat([Alg," is not supported by cryptolib"])} + end. diff --git a/lib/crypto/test/engine_SUITE_data/pkcs8/dsa_private_key.pem b/lib/crypto/test/engine_SUITE_data/pkcs8/dsa_private_key.pem new file mode 100644 index 0000000000..778ffac675 --- /dev/null +++ b/lib/crypto/test/engine_SUITE_data/pkcs8/dsa_private_key.pem @@ -0,0 +1,9 @@ +-----BEGIN PRIVATE KEY----- +MIIBSwIBADCCASwGByqGSM44BAEwggEfAoGBAMyitTMR7vPbpqyAXJpqnB0AhFwQ +F87IE+JKFl5bD/MSkhhRV5sM73HUU1ooXY0FjhZ+cdLUCATuZR5ta4ydANqWIcAB +gX3IwF1B4zf5SXEKTWkUYneL9dOKtiZLtoG28swrk8xMxwX+0fLHkltCEj6FiTW9 +PFrv8GmIfV6DjcI9AhUAqXWbb3RtoN9Ld28fVMhGZrj3LJUCgYEAwnxGHGBMpJaF +2w7zAw3jHjL8PMYlV6vnufGHQlwF0ZUXJxRsvagMb/X1qACTu2VPYEVoLQGM3cfH +EhHoQmvSXGAyTfR7Bmn3gf1n/s/DcFbdZduUCZ/rAyIrfd0eSbc1I+kZk85UCsKK +w/IYdlqcuYa4Cgm2TapT5uEMqH4jhzEEFgIULh8swEUWmU8aJNWsrWl4eCiuUUg= +-----END PRIVATE KEY----- diff --git a/lib/crypto/test/engine_SUITE_data/pkcs8/dsa_public_key.pem b/lib/crypto/test/engine_SUITE_data/pkcs8/dsa_public_key.pem new file mode 100644 index 0000000000..0fa5428828 --- /dev/null +++ b/lib/crypto/test/engine_SUITE_data/pkcs8/dsa_public_key.pem @@ -0,0 +1,12 @@ +-----BEGIN PUBLIC KEY----- +MIIBtzCCASwGByqGSM44BAEwggEfAoGBAMyitTMR7vPbpqyAXJpqnB0AhFwQF87I +E+JKFl5bD/MSkhhRV5sM73HUU1ooXY0FjhZ+cdLUCATuZR5ta4ydANqWIcABgX3I +wF1B4zf5SXEKTWkUYneL9dOKtiZLtoG28swrk8xMxwX+0fLHkltCEj6FiTW9PFrv +8GmIfV6DjcI9AhUAqXWbb3RtoN9Ld28fVMhGZrj3LJUCgYEAwnxGHGBMpJaF2w7z +Aw3jHjL8PMYlV6vnufGHQlwF0ZUXJxRsvagMb/X1qACTu2VPYEVoLQGM3cfHEhHo +QmvSXGAyTfR7Bmn3gf1n/s/DcFbdZduUCZ/rAyIrfd0eSbc1I+kZk85UCsKKw/IY +dlqcuYa4Cgm2TapT5uEMqH4jhzEDgYQAAoGAXPygOFYdeKgfLmuIC303cESYXvic +e2GNJomv8vaWLZmbLVVDfwA1fNsuF1hZkWw8f7aYaN9iZ3yl9u4Yk4TbJKkqfJqd +dgVt288SUqvi+NMHODUzYi9KAOXxupXffZSvdu54gKRaDuFTZ5XNcRqIJWGYlJYg +NVHF5FPZ4Bk2FYA= +-----END PUBLIC KEY----- diff --git a/lib/crypto/test/engine_SUITE_data/pkcs8/ecdsa_private_key.pem b/lib/crypto/test/engine_SUITE_data/pkcs8/ecdsa_private_key.pem new file mode 100644 index 0000000000..a45522064f --- /dev/null +++ b/lib/crypto/test/engine_SUITE_data/pkcs8/ecdsa_private_key.pem @@ -0,0 +1,8 @@ +-----BEGIN PRIVATE KEY----- +MIHuAgEAMBAGByqGSM49AgEGBSuBBAAjBIHWMIHTAgEBBEIBparGjr0KcdNrVM2J +G0mW5ltP1QyvxDqBMyWLWo3fruRZv6Qoohl5skd1u4O+KJoM/UrrSTOXI/MDR7NN +i1yl7O+hgYkDgYYABAG8K2XVsK0ahG9+HIIPwCO0pJY8ulwSTXwIjkCGyB2lpglh +8qJmRzuyGcfRTslv8wfv0sPlT9H9PKDvgrTUL7rvQQDdOODNgVPXSecUoXoPn+X+ +eqxs77bjx+A5x0t/i3m5PfkaNPh5MZ1H/bWuOOdj2ZXZw0R4rlVc0zVrgnPU8L8S +BQ== +-----END PRIVATE KEY----- diff --git a/lib/crypto/test/engine_SUITE_data/pkcs8/ecdsa_public_key.pem b/lib/crypto/test/engine_SUITE_data/pkcs8/ecdsa_public_key.pem new file mode 100644 index 0000000000..6d22fe43fe --- /dev/null +++ b/lib/crypto/test/engine_SUITE_data/pkcs8/ecdsa_public_key.pem @@ -0,0 +1,6 @@ +-----BEGIN PUBLIC KEY----- +MIGbMBAGByqGSM49AgEGBSuBBAAjA4GGAAQBvCtl1bCtGoRvfhyCD8AjtKSWPLpc +Ek18CI5AhsgdpaYJYfKiZkc7shnH0U7Jb/MH79LD5U/R/Tyg74K01C+670EA3Tjg +zYFT10nnFKF6D5/l/nqsbO+248fgOcdLf4t5uT35GjT4eTGdR/21rjjnY9mV2cNE +eK5VXNM1a4Jz1PC/EgU= +-----END PUBLIC KEY----- diff --git a/lib/crypto/test/engine_SUITE_data/pkcs8/rsa_private_key.pem b/lib/crypto/test/engine_SUITE_data/pkcs8/rsa_private_key.pem new file mode 100644 index 0000000000..ea0e3d3958 --- /dev/null +++ b/lib/crypto/test/engine_SUITE_data/pkcs8/rsa_private_key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvwIBADANBgkqhkiG9w0BAQEFAASCBKkwggSlAgEAAoIBAQCwwb0/ddXGXTFK +4FLxXdV6a/WJMSoPPS55RvZIAHFsiTtvPLbJ8LxDsZ6wSVZLN0/UQ4wdWn9jftyj +U5/IxBVG8XOtKimTMvm3/ZOzVLueGHBbrLYscRv9oL85ulTKHWgrZDu0lBX5JJTI +v5UTCErzJRQbka9DG1GaBgDb1PlXfkzBWMwfsBZmwoC77KvCcIGCgbW/XCY03TP2 +3Tg8drvpByMStddP2FQ4fZ91qFUzPu8uhZEsqSQTFlmhgGEx7dLlky0xvu62RuAD +RTpINpcWZtWDHTdssOqu653LwwqBY8lBopCZ/4Af8QR3ZYkQhen1YLEbVheXRuzI +LSCZIiJNAgMBAAECggEBAJH4/fxpqQkvr2Shy33Pu1xlyhnpw01gfn/jrcKasxEq +aC4eWup86E2TY3U8q4pkfIXU3uLi+O9HNpmflwargNLc1mY8uqb44ygiv5bLNEKE +9k2PXcdoBfC4jxPyoNFl5cBn/7LK1TazEjiTl15na9ZPWcLG1pG5/vMPYCgsQ1sP +8J3c4E3aaXIj9QceYxBprl490OCzieGyZlRipncz3g4UShRc/b4cycvDZOJpmAy4 +zbWTcBcSMPVPi5coF0K8UcimiqZkotfb/2RLc433i34IdsIXMM+brdq+g8rmjg5a ++oQPy02M6tFApBruEhAz8DGgaLtDY6MLtyZAt3SjXnUCgYEA1zLgamdTHOqrrmIi +eIQBnAJiyIfcY8B9SX1OsLGYFCHiPVwgUY35B2c7MavMsGcExJhtE+uxU7o5djtM +R6r9cRHOXJ6EQwa8OwzzPqbM17/YqNDeK39bc9WOFUqRWrhDhVMPy6z8rmZr73mG +IUC7mBNx/1GBdVYXIlsXzC96dI8CgYEA0kUAhz6I5nyPa70NDEUYHLHf3IW1BCmE +UoVbraSePJtIEY/IqFx7oDuFo30d4n5z+8ICCtyid1h/Cp3mf3akOiqltYUfgV1G +JgcEjKKYWEnO7cfFyO7LB7Y3GYYDJNy6EzVWPiwTGk9ZTfFJEESmHC45Unxgd17m +Dx/R58rFgWMCgYBQXQWFdtSI5fH7C1bIHrPjKNju/h2FeurOuObcAVZDnmu4cmD3 +U8d9xkVKxVeJQM99A1coq0nrdI3k4zwXP3mp8fZYjDHkPe2pN6rW6L9yiohEcsuk +/siON1/5/4DMmidM8LnjW9R45HLGWWGHpX7oyco2iJ+Jy/6Tq+T1MX3PbQKBgQCm +hdsbQJ0u3CrBSmFQ/E9SOlRt0r4+45pVuCOY6yweF2QF9HcXTtbhWQJHLclDHJ5C +Ha18aKuKFN3XzKFFBPKe1jOSBDGlQ/dQGnKx5fr8wMdObM3oiaTlIJuWbRmEUgJT +QARjDIi8Z2b0YUhZx+Q9oSXoe3PyVYehJrQX+/BavQKBgQCIr7Zp0rQPbfqcTL+M +OYHUoNcb14f9f8hXeXHQOqVpsGwxGdRQAU9wbx/4+obKB5xIkzBsVNcJwavisNja +hegnGjTB/9Hc4m+5bMGwH0bhS2eQO4o+YYM2ypDmFQqDLRfFUlZ5PVHffm/aA9+g +GanNBCsmtoHtV6CJ1UZ7NmBuIA== +-----END PRIVATE KEY----- diff --git a/lib/crypto/test/engine_SUITE_data/pkcs8/rsa_private_key_pwd.pem b/lib/crypto/test/engine_SUITE_data/pkcs8/rsa_private_key_pwd.pem new file mode 100644 index 0000000000..501662fc35 --- /dev/null +++ b/lib/crypto/test/engine_SUITE_data/pkcs8/rsa_private_key_pwd.pem @@ -0,0 +1,30 @@ +-----BEGIN ENCRYPTED PRIVATE KEY----- +MIIFDjBABgkqhkiG9w0BBQ0wMzAbBgkqhkiG9w0BBQwwDgQIh888Iq6gxuMCAggA +MBQGCCqGSIb3DQMHBAic/11YZ8Nt5gSCBMjG/Jb4qiMoBS50iQvHXqcETPE+0NBr +jhsn9w94LkdRBstMPAsoKmY98Er96Rnde/NfmqlU9CupKTkd7Ce5poBf72Y6KMED +cPURyjbGRFsu6x9skXB2obhyKYEqAEF2oQAg4Qbe5v1qXBIgDuC/NgiJnM+w2zCZ +LkHSZB2/NmcnvDzcgPF7TM8pTO23xCJ33m37qjfWvHsgocVqZmL9wQ4+wr/NMYjJ +pJvX1OHW1vBsZsXh40WchalYRSB1VeO368QfsE8coRJztqbMzdce9EQdMB6Q6jlO +cetd3moLIoMP4I7HW0/SgokbycTbRiYSvRyU1TGc2WbW6BrFZV24IckcnnVUFatf +6HKUcaYLG68dJcRgs5QMGkcmgVvlddENHFmHZlo0eym/xSiUl/AT8/5odscm6ML8 +wW5sneax+TF4J2eYmiN7yjAUCodXVTNYNDVKo6uUhntlymbM0o4UitVIbPIfTDHl +sxJAEZ7vpuPqeNMxUk6G6zipuEjqsVbnuFSBSZmgKiGYcifRPUmqqINa3DdS4WVx +xaPWdHbHVRD//ze3h/FsA+1lIE5q2kUE0xXseJA1ISog++kJp14XeaaL2j/tx3Ob +OsbcaOAD/IUw/ItDt9kn0qzfnar7sS0Wov8AmJQxHmH7Lm93jHTLM05yE0AR/eBr +Mig2ZdC+9OqVC+GPuBkRjSs8NpltQIDroz6EV9IMwPwXm0szSYoyoPLmlHJUdnLs +ZUef+au6hYkEJBrvuisagnq5eT/fCV3hsjD7yODebNU2CmBTo6X2PRx/xsBHRMWl +QkoM9PBdSCnKv6HpHl4pchuoqU2NpFjN0BCaad6aHfZSTnqgzK4bEh1oO6dI8/rB +/eh71JyFFG5J4xbpaqz5Su01V1iwU5leK5bDwqals4M4+ZGHGciou7qnXUmX2fJl +r6DlMUa/xy+A2ZG0NuZR05yk2oB3+KVNMgp6zFty3XaxwoNtc8GTLtLnBnIh2rlP +mE1+I65LRWwrNQalPeOAUrYuEzhyp2Df7a8Ykas5PUH7MGR/S0Ge/dLxtE2bJuK4 +znbLAsGhvo/SbNxYqIp6D4iDtd3va6yUGncy41paA/vTKFVvXZDrXcwJQYYCVOGT +OwdzNuozU8Dc7oxsd8oakfC46kvmVaOrGvZbm56PFfprcaL/Hslska5xxEni/eZe +WRxZbCBhAVqS1pn5zkDQVUe9uFlR/x39Qi01HIlKLBsjpSs6qQsFArMe8hgXmXLG +xP+dyVuOE18NzSewdEjeqSRKIM7Qi8EOjZsI4HdSRBY7bh9VhmaVXDZiCSf33TTE +3y8nimzQAeuGoYg6WqHmWWC2Qnpki2HlaIH/ayXEyQWkP/qvg61e8ovdg9Fy8JOO +0AacXVt5zj0q00AW5bKx7usi4NIjZedi86hUm6H19aBm7r86BKjwYTEI/GOcdrbV +9HC/8ayOimgwiAG3gq+aLioWym+Z6KnsbVd7XReVbvM/InQx54WA2y5im0A+/c67 +oQFFPV84XGX9waeqv/K4Wzkm6HW+qVAEM67482VGOf0PVrlQMno6dOotT/Y7ljoZ +2iz0LmN9yylJnLPDrr1i6gzbs5OhhUgbF5LI2YP2wWdCZTl/DrKSIvQZWl8U+tw3 +ciA= +-----END ENCRYPTED PRIVATE KEY----- diff --git a/lib/crypto/test/engine_SUITE_data/pkcs8/rsa_public_key.pem b/lib/crypto/test/engine_SUITE_data/pkcs8/rsa_public_key.pem new file mode 100644 index 0000000000..d3fb5a2cc9 --- /dev/null +++ b/lib/crypto/test/engine_SUITE_data/pkcs8/rsa_public_key.pem @@ -0,0 +1,9 @@ +-----BEGIN PUBLIC KEY----- +MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAsMG9P3XVxl0xSuBS8V3V +emv1iTEqDz0ueUb2SABxbIk7bzy2yfC8Q7GesElWSzdP1EOMHVp/Y37co1OfyMQV +RvFzrSopkzL5t/2Ts1S7nhhwW6y2LHEb/aC/ObpUyh1oK2Q7tJQV+SSUyL+VEwhK +8yUUG5GvQxtRmgYA29T5V35MwVjMH7AWZsKAu+yrwnCBgoG1v1wmNN0z9t04PHa7 +6QcjErXXT9hUOH2fdahVMz7vLoWRLKkkExZZoYBhMe3S5ZMtMb7utkbgA0U6SDaX +FmbVgx03bLDqruudy8MKgWPJQaKQmf+AH/EEd2WJEIXp9WCxG1YXl0bsyC0gmSIi +TQIDAQAB +-----END PUBLIC KEY----- diff --git a/lib/crypto/test/engine_SUITE_data/pkcs8/rsa_public_key_pwd.pem b/lib/crypto/test/engine_SUITE_data/pkcs8/rsa_public_key_pwd.pem new file mode 100644 index 0000000000..f74361cead --- /dev/null +++ b/lib/crypto/test/engine_SUITE_data/pkcs8/rsa_public_key_pwd.pem @@ -0,0 +1,9 @@ +-----BEGIN PUBLIC KEY----- +MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAxquo1Na8C+kjeW0YESGm +vE1bgNW9xh+SQjU1fv/97ePK8mQW2zO1h/vUNz23pfZAKjQu3rlFW/VgGJQ0LgCs +8Gr/HbMwNcCJzuFMePUrnWn/qBeR7OKUZCJ3E1pp4kwsTdGDDO7jPtNzKf0bdKlg +G2GHfZWhUediRX8NsRg12X1odVPuRGVRsyJ952YODk9PFjK7pro7Ynf3Icx7di9d +PXL5vEcKSRdomXvt1rgM8XVHES94RQqoz60ZhfV2JnPfa9V8qu0KaGntpEr7p4rQ +5BSiLFPjPOArjsD5tKyo8ldKCdQjLfisEp7AetfMjLPVVPw9o/SmCjDxsYWTVRQ2 +tQIDAQAB +-----END PUBLIC KEY----- diff --git a/lib/crypto/vsn.mk b/lib/crypto/vsn.mk index 1dceebb4e4..da3915a4fc 100644 --- a/lib/crypto/vsn.mk +++ b/lib/crypto/vsn.mk @@ -1 +1 @@ -CRYPTO_VSN = 4.1 +CRYPTO_VSN = 4.2 diff --git a/lib/debugger/doc/src/Makefile b/lib/debugger/doc/src/Makefile index 0f724b6f17..cc0b8861d3 100644 --- a/lib/debugger/doc/src/Makefile +++ b/lib/debugger/doc/src/Makefile @@ -41,7 +41,7 @@ XML_APPLICATION_FILES = ref_man.xml XML_REF3_FILES = debugger.xml i.xml int.xml XML_PART_FILES = part.xml -XML_CHAPTER_FILES = debugger_chapter.xml notes.xml +XML_CHAPTER_FILES = introduction.xml debugger_chapter.xml notes.xml BOOK_FILES = book.xml diff --git a/lib/debugger/doc/src/notes.xml b/lib/debugger/doc/src/notes.xml index 21fe7d449d..e71746e30d 100644 --- a/lib/debugger/doc/src/notes.xml +++ b/lib/debugger/doc/src/notes.xml @@ -33,6 +33,21 @@ <p>This document describes the changes made to the Debugger application.</p> +<section><title>Debugger 4.2.4</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Do not quote variables and button names in Debugger + windows. The bug was introduced in Erlang/OTP 20.1. </p> + <p> + Own Id: OTP-14802</p> + </item> + </list> + </section> + +</section> + <section><title>Debugger 4.2.3</title> <section><title>Improvements and New Features</title> diff --git a/lib/debugger/src/dbg_wx_win.erl b/lib/debugger/src/dbg_wx_win.erl index 9f59915476..f1298154ab 100644 --- a/lib/debugger/src/dbg_wx_win.erl +++ b/lib/debugger/src/dbg_wx_win.erl @@ -299,7 +299,7 @@ open_help(_Parent, HelpHtmlFile) -> %%-------------------------------------------------------------------- to_string(Atom) when is_atom(Atom) -> - io_lib:format("~tw", [Atom]); + atom_to_list(Atom); to_string(Integer) when is_integer(Integer) -> integer_to_list(Integer); to_string([]) -> ""; diff --git a/lib/debugger/test/guard_SUITE.erl b/lib/debugger/test/guard_SUITE.erl index f7874f79df..e781ea932f 100644 --- a/lib/debugger/test/guard_SUITE.erl +++ b/lib/debugger/test/guard_SUITE.erl @@ -390,7 +390,7 @@ all_types() -> {atom, xxxx}, {ref, make_ref()}, {pid, self()}, - {port, open_port({spawn, efile}, [])}, + {port, make_port()}, {function, fun(X) -> X+1, "" end}, {binary, list_to_binary([])}]. @@ -435,6 +435,9 @@ type_test(binary, X) when binary(X) -> type_test(function, X) when function(X) -> function. +make_port() -> + hd(erlang:ports()). + const_guard(Config) when is_list(Config) -> if (0 == 0) and ((0 == 0) or (0 == 0)) -> diff --git a/lib/debugger/vsn.mk b/lib/debugger/vsn.mk index 72cedb2240..57da7e5618 100644 --- a/lib/debugger/vsn.mk +++ b/lib/debugger/vsn.mk @@ -1 +1 @@ -DEBUGGER_VSN = 4.2.3 +DEBUGGER_VSN = 4.2.4 diff --git a/lib/dialyzer/doc/src/notes.xml b/lib/dialyzer/doc/src/notes.xml index 6a6e65cb94..a1eecfb3fe 100644 --- a/lib/dialyzer/doc/src/notes.xml +++ b/lib/dialyzer/doc/src/notes.xml @@ -32,6 +32,29 @@ <p>This document describes the changes made to the Dialyzer application.</p> +<section><title>Dialyzer 3.2.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> The error message returned from Dialyzer when, for + example, a modified record field type is not a subtype of + the declared type, no longer includes a call stack. The + bug was introduced in Erlang/OTP 19.3. </p> + <p> + Own Id: OTP-14742</p> + </item> + <item> + <p> A bug relating to maps and never returning functions + has been fixed. </p> + <p> + Own Id: OTP-14743</p> + </item> + </list> + </section> + +</section> + <section><title>Dialyzer 3.2.2</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/dialyzer/src/dialyzer_analysis_callgraph.erl b/lib/dialyzer/src/dialyzer_analysis_callgraph.erl index a4b42c9367..9993c68fed 100644 --- a/lib/dialyzer/src/dialyzer_analysis_callgraph.erl +++ b/lib/dialyzer/src/dialyzer_analysis_callgraph.erl @@ -165,7 +165,11 @@ analysis_start(Parent, Analysis, LegalWarnings) -> remote_type_postprocessing(TmpCServer, Args) -> Fun = fun() -> - exit(remote_type_postproc(TmpCServer, Args)) + exit(try remote_type_postproc(TmpCServer, Args) of + R -> R + catch + throw:{error,_}=Error -> Error + end) end, {Pid, Ref} = erlang:spawn_monitor(Fun), dialyzer_codeserver:give_away(TmpCServer, Pid), diff --git a/lib/dialyzer/src/dialyzer_dataflow.erl b/lib/dialyzer/src/dialyzer_dataflow.erl index 8367432ac5..384912f983 100644 --- a/lib/dialyzer/src/dialyzer_dataflow.erl +++ b/lib/dialyzer/src/dialyzer_dataflow.erl @@ -299,6 +299,7 @@ traverse(Tree, Map, State) -> match_fail -> t_none(); raise -> t_none(); bs_init_writable -> t_from_term(<<>>); + build_stacktrace -> t_list(); Other -> erlang:error({'Unsupported primop', Other}) end, {State, Map, Type}; @@ -3116,7 +3117,10 @@ state__add_warning(#state{warnings = Warnings, warning_mode = true} = State, state__remove_added_warnings(OldState, NewState) -> #state{warnings = OldWarnings} = OldState, #state{warnings = NewWarnings} = NewState, - {NewWarnings -- OldWarnings, NewState#state{warnings = OldWarnings}}. + case NewWarnings =:= OldWarnings of + true -> {[], NewState}; + false -> {NewWarnings -- OldWarnings, NewState#state{warnings = OldWarnings}} + end. state__add_warnings(Warns, #state{warnings = Warnings} = State) -> State#state{warnings = Warns ++ Warnings}. diff --git a/lib/dialyzer/src/dialyzer_typesig.erl b/lib/dialyzer/src/dialyzer_typesig.erl index c4d8f45447..b1f6a54503 100644 --- a/lib/dialyzer/src/dialyzer_typesig.erl +++ b/lib/dialyzer/src/dialyzer_typesig.erl @@ -41,7 +41,7 @@ t_is_float/1, t_is_fun/1, t_is_integer/1, t_non_neg_integer/0, t_is_list/1, t_is_nil/1, t_is_none/1, t_is_number/1, - t_is_singleton/1, + t_is_singleton/1, t_is_none_or_unit/1, t_limit/2, t_list/0, t_list/1, t_list_elements/1, t_nonempty_list/1, t_maybe_improper_list/0, @@ -418,6 +418,7 @@ traverse(Tree, DefinedVars, State) -> match_fail -> throw(error); raise -> throw(error); bs_init_writable -> {State, t_from_term(<<>>)}; + build_stacktrace -> {State, t_list()}; Other -> erlang:error({'Unsupported primop', Other}) end; 'receive' -> @@ -528,13 +529,14 @@ traverse(Tree, DefinedVars, State) -> false -> t_any(); true -> MT = t_inf(lookup_type(MapVar, Map), t_map()), - case t_is_none(MT) of + case t_is_none_or_unit(MT) of true -> t_none(); false -> DisjointFromKeyType = fun(ShadowKey) -> - t_is_none(t_inf(lookup_type(ShadowKey, Map), - KeyType)) + ST = t_inf(lookup_type(ShadowKey, Map), + KeyType), + t_is_none_or_unit(ST) end, case lists:all(DisjointFromKeyType, ShadowKeys) of true -> t_map_get(KeyType, MT); @@ -567,7 +569,8 @@ traverse(Tree, DefinedVars, State) -> case cerl:is_literal(OpTree) andalso cerl:concrete(OpTree) =:= exact of true -> - case t_is_none(t_inf(ShadowedKeys, KeyType)) of + ST = t_inf(ShadowedKeys, KeyType), + case t_is_none_or_unit(ST) of true -> t_map_put({KeyType, t_any()}, AccType); false -> diff --git a/lib/dialyzer/test/map_SUITE_data/results/map_anon_fun b/lib/dialyzer/test/map_SUITE_data/results/map_anon_fun new file mode 100644 index 0000000000..cfca5b1407 --- /dev/null +++ b/lib/dialyzer/test/map_SUITE_data/results/map_anon_fun @@ -0,0 +1,2 @@ + +map_anon_fun.erl:4: Function g/1 will never be called diff --git a/lib/dialyzer/test/map_SUITE_data/src/map_anon_fun.erl b/lib/dialyzer/test/map_SUITE_data/src/map_anon_fun.erl new file mode 100644 index 0000000000..e77016d68a --- /dev/null +++ b/lib/dialyzer/test/map_SUITE_data/src/map_anon_fun.erl @@ -0,0 +1,9 @@ +-module(map_anon_fun). + +%% Not exported. +g(A) -> + maps:map(fun F(K, {V, _C}) -> + F(K, V); + F(_K, _V) -> + #{ system => {A} } + end, #{}). diff --git a/lib/dialyzer/test/plt_SUITE.erl b/lib/dialyzer/test/plt_SUITE.erl index ebe79b2a6d..680f5b5088 100644 --- a/lib/dialyzer/test/plt_SUITE.erl +++ b/lib/dialyzer/test/plt_SUITE.erl @@ -9,14 +9,14 @@ -export([suite/0, all/0, build_plt/1, beam_tests/1, update_plt/1, local_fun_same_as_callback/1, remove_plt/1, run_plt_check/1, run_succ_typings/1, - bad_dialyzer_attr/1, merge_plts/1]). + bad_dialyzer_attr/1, merge_plts/1, bad_record_type/1]). suite() -> [{timetrap, ?plt_timeout}]. all() -> [build_plt, beam_tests, update_plt, run_plt_check, remove_plt, run_succ_typings, local_fun_same_as_callback, - bad_dialyzer_attr, merge_plts]. + bad_dialyzer_attr, merge_plts, bad_record_type]. build_plt(Config) -> OutDir = ?config(priv_dir, Config), @@ -283,8 +283,8 @@ bad_dialyzer_attr(Config) -> {dialyzer_error, "Analysis failed with error:\n" ++ Str1} = (catch dialyzer:run(Opts)), - P1 = string:str(Str1, "dial.erl:2: function undef/0 undefined"), - true = P1 > 0, + S1 = string:find(Str1, "dial.erl:2: function undef/0 undefined"), + true = is_list(S1), Prog2 = <<"-module(dial). -dialyzer({no_return, [{undef,1,2}]}).">>, @@ -292,9 +292,9 @@ bad_dialyzer_attr(Config) -> {dialyzer_error, "Analysis failed with error:\n" ++ Str2} = (catch dialyzer:run(Opts)), - P2 = string:str(Str2, "dial.erl:2: badly formed dialyzer " - "attribute: {no_return,{undef,1,2}}"), - true = P2 > 0, + S2 = string:find(Str2, "dial.erl:2: badly formed dialyzer " + "attribute: {no_return,{undef,1,2}}"), + true = is_list(S2), ok. @@ -369,6 +369,32 @@ create_plts(Mod1, Mod2, Config) -> %% End of merge_plts(). +bad_record_type(Config) -> + PrivDir = ?config(priv_dir, Config), + Source = lists:concat([bad_record_type, ".erl"]), + Filename = filename:join(PrivDir, Source), + PltFilename = dialyzer_common:plt_file(PrivDir), + + Opts = [{files, [Filename]}, + {check_plt, false}, + {from, src_code}, + {init_plt, PltFilename}], + + Prog = <<"-module(bad_record_type). + -export([r/0]). + -record(r, {f = 3 :: integer()}). + -spec r() -> #r{f :: atom()}. + r() -> + #r{}.">>, + ok = file:write_file(Filename, Prog), + {dialyzer_error, + "Analysis failed with error:\n" ++ Str} = + (catch dialyzer:run(Opts)), + P = string:str(Str, + "bad_record_type.erl:4: Illegal declaration of #r{f}"), + true = P > 0, + ok. + erlang_beam() -> case code:where_is_file("erlang.beam") of non_existing -> diff --git a/lib/dialyzer/test/small_SUITE_data/results/maps_sum b/lib/dialyzer/test/small_SUITE_data/results/maps_sum index bd192bdb93..b29ac77d88 100644 --- a/lib/dialyzer/test/small_SUITE_data/results/maps_sum +++ b/lib/dialyzer/test/small_SUITE_data/results/maps_sum @@ -1,4 +1,4 @@ -maps_sum.erl:15: Invalid type specification for function maps_sum:wrong1/1. The success typing is (map()) -> any() +maps_sum.erl:15: Invalid type specification for function maps_sum:wrong1/1. The success typing is (maps:iterator() | map()) -> any() maps_sum.erl:26: Function wrong2/1 has no local return maps_sum.erl:27: The call lists:foldl(fun((_,_,_) -> any()),0,Data::any()) will never return since it differs in the 1st argument from the success typing arguments: (fun((_,_) -> any()),any(),[any()]) diff --git a/lib/dialyzer/test/small_SUITE_data/src/abs.erl b/lib/dialyzer/test/small_SUITE_data/src/abs.erl index 251e24cdfc..0e38c3dbb7 100644 --- a/lib/dialyzer/test/small_SUITE_data/src/abs.erl +++ b/lib/dialyzer/test/small_SUITE_data/src/abs.erl @@ -5,7 +5,7 @@ -export([t/0]). t() -> - Fs = [fun i1/0, fun i2/0, fun i3/0, fun i4/0, fun f1/0], + Fs = [fun i1/0, fun i2/0, fun i3/0, fun i4/0, fun f1/0, fun erl_551/0], _ = [catch F() || F <- Fs], ok. @@ -60,6 +60,13 @@ f1() -> f1(A) -> abs(A). +erl_551() -> + accept(9), + accept(-3). + +accept(Number) when abs(Number) >= 8 -> first; +accept(_Number) -> second. + -spec int() -> integer(). int() -> diff --git a/lib/dialyzer/test/small_SUITE_data/src/bsL.erl b/lib/dialyzer/test/small_SUITE_data/src/bsL.erl new file mode 100644 index 0000000000..b2fdc16324 --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/src/bsL.erl @@ -0,0 +1,13 @@ +-module(bsL). + +-export([t/0]). + +%% Found in lib/observer/test/crashdump_helper.erl. + +t() -> + Size = 60, + <<H:16/unit:8>> = erlang:md5(<<Size:32>>), + true = H < 20, + true = H > 2, + Data = ((H bsl (8*150)) div (H+7919)), + <<Data:Size/unit:8>>. diff --git a/lib/dialyzer/test/small_SUITE_data/src/erl_tar_table.erl b/lib/dialyzer/test/small_SUITE_data/src/erl_tar_table.erl new file mode 100644 index 0000000000..2dc00d272a --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/src/erl_tar_table.erl @@ -0,0 +1,14 @@ +-module(erl_tar_table). + +%% OTP-14860, PR 1670. + +-export([t/0, v/0, x/0]). + +t() -> + {ok, ["file"]} = erl_tar:table("table.tar"). + +v() -> + {ok, [{_,_,_,_,_,_,_}]} = erl_tar:table("table.tar", [verbose]). + +x() -> + {ok, ["file"]} = erl_tar:table("table.tar", []). diff --git a/lib/dialyzer/vsn.mk b/lib/dialyzer/vsn.mk index d130b14fec..1b46f66602 100644 --- a/lib/dialyzer/vsn.mk +++ b/lib/dialyzer/vsn.mk @@ -1 +1 @@ -DIALYZER_VSN = 3.2.2 +DIALYZER_VSN = 3.2.3 diff --git a/lib/diameter/doc/src/notes.xml b/lib/diameter/doc/src/notes.xml index eded788419..ba4525fd20 100644 --- a/lib/diameter/doc/src/notes.xml +++ b/lib/diameter/doc/src/notes.xml @@ -43,6 +43,22 @@ first.</p> <!-- ===================================================================== --> +<section><title>diameter 2.1.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Fix documentation typo: peer_down/3 was written where + peer_down/3 was intended.</p> + <p> + Own Id: OTP-14805</p> + </item> + </list> + </section> + +</section> + <section><title>diameter 2.1.2</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/diameter/doc/src/seealso.ent b/lib/diameter/doc/src/seealso.ent index c5a53670d0..72d74c103c 100644 --- a/lib/diameter/doc/src/seealso.ent +++ b/lib/diameter/doc/src/seealso.ent @@ -79,7 +79,7 @@ significant. <!ENTITY app_handle_answer '<seealso marker="diameter_app#Mod:handle_answer-4">handle_answer/4</seealso>'> <!ENTITY app_handle_request '<seealso marker="diameter_app#Mod:handle_request-3">handle_request/3</seealso>'> <!ENTITY app_handle_error '<seealso marker="diameter_app#Mod:handle_error-4">handle_error/4</seealso>'> -<!ENTITY app_peer_down '<seealso marker="diameter_app#Mod:peer_down-3">peer_up/3</seealso>'> +<!ENTITY app_peer_down '<seealso marker="diameter_app#Mod:peer_down-3">peer_down/3</seealso>'> <!ENTITY app_peer_up '<seealso marker="diameter_app#Mod:peer_up-3">peer_up/3</seealso>'> <!ENTITY app_pick_peer '<seealso marker="diameter_app#Mod:pick_peer-4">pick_peer/4</seealso>'> <!ENTITY app_prepare_retransmit '<seealso marker="diameter_app#Mod:prepare_retransmit-3">prepare_retransmit/3</seealso>'> diff --git a/lib/diameter/src/diameter.appup.src b/lib/diameter/src/diameter.appup.src index d0e58e8410..7da59f8b25 100644 --- a/lib/diameter/src/diameter.appup.src +++ b/lib/diameter/src/diameter.appup.src @@ -56,7 +56,8 @@ {"2.0", [{restart_application, diameter}]}, %% 20.0 {"2.1", [{load_module, diameter_gen}, %% 20.1 {update, diameter_reg, {advanced, "2.1"}}]}, - {"2.1.1", [{load_module, diameter_gen}]} + {"2.1.1", [{load_module, diameter_gen}]}, %% 20.1.2 + {"2.1.2", []} %% 20.1.3 ], [ {"0.9", [{restart_application, diameter}]}, @@ -93,6 +94,7 @@ {"1.12.2", [{restart_application, diameter}]}, {"2.0", [{restart_application, diameter}]}, {"2.1", [{restart_application, diameter}]}, - {"2.1.1", [{load_module, diameter_gen}]} + {"2.1.1", [{load_module, diameter_gen}]}, + {"2.1.2", []} ] }. diff --git a/lib/diameter/vsn.mk b/lib/diameter/vsn.mk index bfb260ed8f..0c852d75cd 100644 --- a/lib/diameter/vsn.mk +++ b/lib/diameter/vsn.mk @@ -17,5 +17,5 @@ # %CopyrightEnd% APPLICATION = diameter -DIAMETER_VSN = 2.1.2 +DIAMETER_VSN = 2.1.3 APP_VSN = $(APPLICATION)-$(DIAMETER_VSN)$(PRE_VSN) diff --git a/lib/edoc/doc/src/notes.xml b/lib/edoc/doc/src/notes.xml index 96d7597d83..240789e876 100644 --- a/lib/edoc/doc/src/notes.xml +++ b/lib/edoc/doc/src/notes.xml @@ -32,6 +32,21 @@ <p>This document describes the changes made to the EDoc application.</p> +<section><title>Edoc 0.9.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> The map type is correctly denoted as <c>map()</c> in + function specifications and types. </p> + <p> + Own Id: OTP-14777</p> + </item> + </list> + </section> + +</section> + <section><title>Edoc 0.9.1</title> <section><title>Improvements and New Features</title> diff --git a/lib/edoc/src/edoc_specs.erl b/lib/edoc/src/edoc_specs.erl index 26b7202462..7b451c43f8 100644 --- a/lib/edoc/src/edoc_specs.erl +++ b/lib/edoc/src/edoc_specs.erl @@ -372,7 +372,7 @@ d2e({type,_,binary,[Base,Unit]}, _Prec) -> {integer,_,U} = erl_eval:partial_eval(Unit), #t_binary{base_size = B, unit_size = U}; d2e({type,_,map,any}, _Prec) -> - #t_map{types = []}; + #t_type{name = #t_name{name = map}, args = []}; d2e({type,_,map,Es}, _Prec) -> #t_map{types = d2e(Es) }; d2e({type,_,map_field_assoc,[K,V]}, Prec) -> diff --git a/lib/edoc/vsn.mk b/lib/edoc/vsn.mk index 065944ccef..2f6d469536 100644 --- a/lib/edoc/vsn.mk +++ b/lib/edoc/vsn.mk @@ -1 +1 @@ -EDOC_VSN = 0.9.1 +EDOC_VSN = 0.9.2 diff --git a/lib/eldap/doc/src/Makefile b/lib/eldap/doc/src/Makefile index ac869e446f..aff1da4a9a 100644 --- a/lib/eldap/doc/src/Makefile +++ b/lib/eldap/doc/src/Makefile @@ -37,7 +37,7 @@ RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) XML_APPLICATION_FILES = ref_man.xml XML_REF3_FILES = eldap.xml -XML_PART_FILES = release_notes.xml usersguide.xml +XML_PART_FILES = usersguide.xml XML_CHAPTER_FILES = notes.xml BOOK_FILES = book.xml diff --git a/lib/eldap/doc/src/notes.xml b/lib/eldap/doc/src/notes.xml index 7aad745f67..8b066671ee 100644 --- a/lib/eldap/doc/src/notes.xml +++ b/lib/eldap/doc/src/notes.xml @@ -31,6 +31,21 @@ </header> <p>This document describes the changes made to the Eldap application.</p> +<section><title>Eldap 1.2.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + <section><title>Eldap 1.2.2</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/eldap/vsn.mk b/lib/eldap/vsn.mk index 721387d97d..1636b6bb6d 100644 --- a/lib/eldap/vsn.mk +++ b/lib/eldap/vsn.mk @@ -1 +1 @@ -ELDAP_VSN = 1.2.2 +ELDAP_VSN = 1.2.3 diff --git a/lib/erl_docgen/doc/src/notes.xml b/lib/erl_docgen/doc/src/notes.xml index 59c65665d4..2652b4b0c8 100644 --- a/lib/erl_docgen/doc/src/notes.xml +++ b/lib/erl_docgen/doc/src/notes.xml @@ -31,7 +31,26 @@ </header> <p>This document describes the changes made to the <em>erl_docgen</em> application.</p> - <section><title>Erl_Docgen 0.7.1</title> + <section><title>Erl_Docgen 0.7.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> The style for code, warning and note tags in the pdf + have been changed so they look like the html version. + <br/> The spacing around code blocks have been changed + for both html and pdf so it's the same regardless if the + user have a newline after the start tag (or before the + end tag) or not. </p> + <p> + Own Id: OTP-14674</p> + </item> + </list> + </section> + +</section> + +<section><title>Erl_Docgen 0.7.1</title> <section><title>Improvements and New Features</title> <list> diff --git a/lib/erl_docgen/priv/dtd/erlref.dtd b/lib/erl_docgen/priv/dtd/erlref.dtd index 615b88b61a..78d6771f52 100644 --- a/lib/erl_docgen/priv/dtd/erlref.dtd +++ b/lib/erl_docgen/priv/dtd/erlref.dtd @@ -33,4 +33,5 @@ <!ATTLIST name name CDATA #IMPLIED arity CDATA #IMPLIED clause_i CDATA #IMPLIED + anchor CDATA #IMPLIED n_vars CDATA #IMPLIED> diff --git a/lib/erl_docgen/priv/xsl/db_html.xsl b/lib/erl_docgen/priv/xsl/db_html.xsl index 75614392fb..5b7eae4f73 100644 --- a/lib/erl_docgen/priv/xsl/db_html.xsl +++ b/lib/erl_docgen/priv/xsl/db_html.xsl @@ -172,6 +172,7 @@ <xsl:template name="spec_name"> <xsl:variable name="name" select="@name"/> <xsl:variable name="arity" select="@arity"/> + <xsl:variable name="anchor" select="@anchor"/> <xsl:variable name="spec0"> <xsl:call-template name="find_spec"/> </xsl:variable> @@ -198,6 +199,11 @@ </xsl:otherwise> </xsl:choose> + <!-- Insert an anchor for "anchor" attribute --> + <xsl:if test="string-length($anchor) > 0"> + <a name="{$anchor}"></a> + </xsl:if> + <xsl:variable name="global_types" select="ancestor::erlref/datatypes"/> <xsl:variable name="local_types" select="../type[string-length(@name) > 0]"/> diff --git a/lib/erl_docgen/src/docgen_edoc_xml_cb.erl b/lib/erl_docgen/src/docgen_edoc_xml_cb.erl index 67e6e33c93..b065c18cda 100644 --- a/lib/erl_docgen/src/docgen_edoc_xml_cb.erl +++ b/lib/erl_docgen/src/docgen_edoc_xml_cb.erl @@ -489,6 +489,8 @@ otp_xmlify_a_href("#"++_ = Marker, Es0) -> % <seealso marker="#what"> {Marker, Es0}; otp_xmlify_a_href("http:"++_ = URL, Es0) -> % external URL {URL, Es0}; +otp_xmlify_a_href("https:"++_ = URL, Es0) -> % external URL + {URL, Es0}; otp_xmlify_a_href("OTPROOT"++AppRef, Es0) -> % <.. marker="App:FileRef [AppS, "doc", FileRef1] = split(AppRef, "/"), FileRef = AppS++":"++otp_xmlify_a_fileref(FileRef1, AppS), diff --git a/lib/erl_docgen/vsn.mk b/lib/erl_docgen/vsn.mk index 17a7c483f4..95b2329ac5 100644 --- a/lib/erl_docgen/vsn.mk +++ b/lib/erl_docgen/vsn.mk @@ -1 +1 @@ -ERL_DOCGEN_VSN = 0.7.1 +ERL_DOCGEN_VSN = 0.7.2 diff --git a/lib/erl_interface/doc/src/Makefile b/lib/erl_interface/doc/src/Makefile index a96ef62786..8ef7e9648c 100644 --- a/lib/erl_interface/doc/src/Makefile +++ b/lib/erl_interface/doc/src/Makefile @@ -53,7 +53,7 @@ XML_APPLICATION_FILES = ref_man.xml #ref_man_ei.xml ref_man_erl_interface.xml XML_PART_FILES = \ part.xml -XML_CHAPTER_FILES = ei_users_guide.xml notes.xml notes_history.xml +XML_CHAPTER_FILES = ei_users_guide.xml notes.xml XML_FILES = $(XML_REF1_FILES) $(XML_REF3_FILES) $(BOOK_FILES) \ $(XML_APPLICATION_FILES) $(XML_PART_FILES) $(XML_CHAPTER_FILES) diff --git a/lib/erl_interface/doc/src/notes.xml b/lib/erl_interface/doc/src/notes.xml index ec20f3c67f..641a3de13f 100644 --- a/lib/erl_interface/doc/src/notes.xml +++ b/lib/erl_interface/doc/src/notes.xml @@ -31,6 +31,21 @@ </header> <p>This document describes the changes made to the Erl_interface application.</p> +<section><title>Erl_Interface 3.10.1</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + <section><title>Erl_Interface 3.10</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/erl_interface/src/Makefile b/lib/erl_interface/src/Makefile index 31f34d4bba..135522397b 100644 --- a/lib/erl_interface/src/Makefile +++ b/lib/erl_interface/src/Makefile @@ -29,5 +29,5 @@ include $(ERL_TOP)/make/target.mk debug opt shared purify quantify purecov gcov: $(make_verbose)$(MAKE) -f $(TARGET)/Makefile TYPE=$@ -clean depend docs release release_docs tests release_tests check: +clean depend docs release release_docs tests release_tests check xmllint: $(make_verbose)$(MAKE) -f $(TARGET)/Makefile $@ diff --git a/lib/erl_interface/src/Makefile.in b/lib/erl_interface/src/Makefile.in index 4f393e952c..69b5b6003d 100644 --- a/lib/erl_interface/src/Makefile.in +++ b/lib/erl_interface/src/Makefile.in @@ -854,3 +854,5 @@ endif release_docs: release_tests: + +xmllint: diff --git a/lib/erl_interface/test/ei_accept_SUITE.erl b/lib/erl_interface/test/ei_accept_SUITE.erl index e06ee762d7..6676e73e21 100644 --- a/lib/erl_interface/test/ei_accept_SUITE.erl +++ b/lib/erl_interface/test/ei_accept_SUITE.erl @@ -25,7 +25,8 @@ -include("ei_accept_SUITE_data/ei_accept_test_cases.hrl"). -export([all/0, suite/0, - ei_accept/1, ei_threaded_accept/1]). + ei_accept/1, ei_threaded_accept/1, + monitor_ei_process/1]). -import(runner, [get_term/1,send_term/2]). @@ -34,7 +35,8 @@ suite() -> {timetrap, {seconds, 30}}]. all() -> - [ei_accept, ei_threaded_accept]. + [ei_accept, ei_threaded_accept, + monitor_ei_process]. ei_accept(Config) when is_list(Config) -> P = runner:start(?interpret), @@ -44,33 +46,32 @@ ei_accept(Config) when is_list(Config) -> io:format("Myname ~p ~n", [Myname]), EINode = list_to_atom("c42@"++Myname), io:format("EINode ~p ~n", [EINode]), + + %% We take this opportunity to also test export-funs and bit-strings + %% with (ugly) tuple fallbacks. + %% Test both toward pending connection and established connection. + RealTerms = [<<1:1>>, fun lists:map/2], + Fallbacks = [{<<128>>,1}, {lists,map}], + Self = self(), - TermToSend= {call, Self, "Test"}, - F= fun() -> - case waitfornode("c42",20) of - true -> - {any, EINode} ! TermToSend, - Self ! sent_ok; - false -> - Self ! never_published - end, - ok - end, - - spawn(F), + Funny = fun() -> hello end, + TermToSend = {call, Self, "Test", Funny, RealTerms}, + TermToGet = {call, Self, "Test", Funny, Fallbacks}, Port = 6543, - {ok, Fd, _Node} = ei_accept(P, Port), - TermReceived= ei_receive(P, Fd), - io:format("Sent ~p received ~p ~n", [TermToSend, TermReceived]), - TermToSend= TermReceived, - receive - sent_ok -> - ok; - Unknown -> - io:format("~p ~n", [Unknown]) - after 1000 -> - io:format("timeout ~n") - end, + {ok, ListenFd} = ei_publish(P, Port), + {any, EINode} ! TermToSend, + + {ok, Fd, _Node} = ei_accept(P, ListenFd), + Got1 = ei_receive(P, Fd), + + %% Send again, now without auto-connect + {any, EINode} ! TermToSend, + Got2 = ei_receive(P, Fd), + + io:format("Sent ~p~nExp. ~p~nGot1 ~p~nGot2 ~p~n", [TermToSend, TermToGet, Got1, Got2]), + TermToGet = Got1, + TermToGet = Got2, + runner:finish(P), ok. @@ -87,6 +88,41 @@ ei_threaded_accept(Config) when is_list(Config) -> [receive I -> ok end || I <- lists:seq(0, N-1) ], ok. + +%% Test erlang:monitor toward erl_interface "processes" +monitor_ei_process(Config) when is_list(Config) -> + P = runner:start(?interpret), + 0 = ei_connect_init(P, 42, erlang:get_cookie(), 0), + + Myname = hd(tl(string:tokens(atom_to_list(node()), "@"))), + io:format("Myname ~p ~n", [Myname]), + EINode = list_to_atom("c42@"++Myname), + io:format("EINode ~p ~n", [EINode]), + + Self = self(), + Port = 6543, + {ok, ListenFd} = ei_publish(P, Port), + MRef1 = erlang:monitor(process, {any, EINode}), + {any, EINode} ! hello, + + {ok, Fd, _Node} = ei_accept(P, ListenFd), + hello = ei_receive(P, Fd), + + %% Again, now on an established connection. + MRef2 = erlang:monitor(process, {any, EINode}), + {any, EINode} ! hello, + hello = ei_receive(P, Fd), + + ok = receive M -> M after 0 -> ok end, + + runner:finish(P), + + [{'DOWN', MRef1, process, {any, EINode}, noconnection}, + {'DOWN', MRef2, process, {any, EINode}, noconnection} + ] = lists:sort(flush(2, 1000)), + + ok. + waitfornode(String,0) -> io:format("~s never published itself.~n",[String]), false; @@ -137,8 +173,15 @@ ei_connect_init(P, Num, Cookie, Creation) -> {term,Int} when is_integer(Int) -> Int end. -ei_accept(P, PortNo) -> - send_command(P, ei_accept, [PortNo]), +ei_publish(P, PortNo) -> + send_command(P, ei_publish, [PortNo]), + case get_term(P) of + {term,{ListenFd, EpmdFd, _}} when ListenFd >= 0, EpmdFd >= 0 -> {ok, ListenFd}; + {term,{_, _, Errno}} -> {error,Errno} + end. + +ei_accept(P, ListenFd) -> + send_command(P, ei_accept, [ListenFd]), case get_term(P) of {term,{Fd, _, Node}} when Fd >= 0 -> {ok, Fd, Node}; {term,{_Fd, Errno, _Node}} -> {error,Errno} @@ -151,3 +194,12 @@ ei_receive(P, Fd) -> send_command(P, Name, Args) -> runner:send_term(P, {Name,list_to_tuple(Args)}). + +flush(0, Timeout) -> + flush(1, Timeout div 10); +flush(Expected, Timeout) -> + receive M -> + [M | flush(Expected-1, Timeout)] + after Timeout -> + [] + end. diff --git a/lib/erl_interface/test/ei_accept_SUITE_data/ei_accept_test.c b/lib/erl_interface/test/ei_accept_SUITE_data/ei_accept_test.c index 7b81ee5491..2b62d7c3a4 100644 --- a/lib/erl_interface/test/ei_accept_SUITE_data/ei_accept_test.c +++ b/lib/erl_interface/test/ei_accept_SUITE_data/ei_accept_test.c @@ -43,6 +43,7 @@ #include "ei_runner.h" static void cmd_ei_connect_init(char* buf, int len); +static void cmd_ei_publish(char* buf, int len); static void cmd_ei_accept(char* buf, int len); static void cmd_ei_receive(char* buf, int len); static void cmd_ei_unpublish(char* buf, int len); @@ -58,6 +59,7 @@ static struct { void (*func)(char* buf, int len); } commands[] = { "ei_connect_init", 3, cmd_ei_connect_init, + "ei_publish", 1, cmd_ei_publish, "ei_accept", 1, cmd_ei_accept, "ei_receive", 1, cmd_ei_receive, "ei_unpublish", 0, cmd_ei_unpublish @@ -149,11 +151,10 @@ static int my_listen(int port) return listen_fd; } -static void cmd_ei_accept(char* buf, int len) +static void cmd_ei_publish(char* buf, int len) { int index = 0; int listen, r; - ErlConnect conn; long port; ei_x_buff x; int i; @@ -170,6 +171,29 @@ static void cmd_ei_accept(char* buf, int len) #ifdef VXWORKS save_fd(i); #endif + /* send listen-fd, result and errno */ + ei_x_new_with_version(&x); + ei_x_encode_tuple_header(&x, 3); + ei_x_encode_long(&x, listen); + ei_x_encode_long(&x, i); + ei_x_encode_long(&x, erl_errno); + send_bin_term(&x); + ei_x_free(&x); +} + +static void cmd_ei_accept(char* buf, int len) +{ + int index = 0; + int r; + ErlConnect conn; + long listen; + ei_x_buff x; + int i; + + /* get port */ + if (ei_decode_long(buf, &index, &listen) < 0) + fail("expected int (listen fd)"); + r = ei_accept(&ec, listen, &conn); #ifdef VXWORKS save_fd(r); @@ -200,7 +224,7 @@ static void cmd_ei_receive(char* buf, int len) if (got == ERL_TICK) continue; if (got == ERL_ERROR) - fail("ei_xreceive_msg"); + fail1("ei_xreceive_msg, got==%d", got); break; } index = 1; diff --git a/lib/erl_interface/test/runner.erl b/lib/erl_interface/test/runner.erl index 1084eec2a3..cbdeb3c8a9 100644 --- a/lib/erl_interface/test/runner.erl +++ b/lib/erl_interface/test/runner.erl @@ -67,7 +67,12 @@ start({Prog, Tc}) when is_list(Prog), is_integer(Tc) -> finish(Port) when is_port(Port) -> send_eot(Port), - recv_eot(Port). + ok = recv_eot(Port), + 0 = receive + {Port,{exit_status,Status}} -> + Status + end, + ok. %% Sends an Erlang term to a C program. diff --git a/lib/erl_interface/vsn.mk b/lib/erl_interface/vsn.mk index 01fcee86dd..d76d110afd 100644 --- a/lib/erl_interface/vsn.mk +++ b/lib/erl_interface/vsn.mk @@ -1,2 +1,2 @@ -EI_VSN = 3.10 +EI_VSN = 3.10.1 ERL_INTERFACE_VSN = $(EI_VSN) diff --git a/lib/eunit/doc/src/notes.xml b/lib/eunit/doc/src/notes.xml index 7133befe37..b38cb2e70e 100644 --- a/lib/eunit/doc/src/notes.xml +++ b/lib/eunit/doc/src/notes.xml @@ -33,6 +33,21 @@ </header> <p>This document describes the changes made to the EUnit application.</p> +<section><title>Eunit 2.3.5</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + <section><title>Eunit 2.3.4</title> <section><title>Improvements and New Features</title> diff --git a/lib/eunit/vsn.mk b/lib/eunit/vsn.mk index 25bb0dec17..2ed9eaac16 100644 --- a/lib/eunit/vsn.mk +++ b/lib/eunit/vsn.mk @@ -1 +1 @@ -EUNIT_VSN = 2.3.4 +EUNIT_VSN = 2.3.5 diff --git a/lib/hipe/cerl/erl_bif_types.erl b/lib/hipe/cerl/erl_bif_types.erl index a3a936322a..5fda857bf1 100644 --- a/lib/hipe/cerl/erl_bif_types.erl +++ b/lib/hipe/cerl/erl_bif_types.erl @@ -1701,24 +1701,6 @@ type(maps, size, 1, Xs, Opaques) -> t_from_range(LowerBound, UpperBound) end end, Opaques); -type(maps, to_list, 1, Xs, Opaques) -> - strict(maps, to_list, 1, Xs, - fun ([Map]) -> - DefK = t_map_def_key(Map, Opaques), - DefV = t_map_def_val(Map, Opaques), - Pairs = t_map_entries(Map, Opaques), - EType = lists:foldl( - fun({K,_,V},EType0) -> - case t_is_none(V) of - true -> t_subtract(EType0, t_tuple([K,t_any()])); - false -> t_sup(EType0, t_tuple([K,V])) - end - end, t_tuple([DefK, DefV]), Pairs), - case t_is_none(EType) of - true -> t_nil(); - false -> t_list(EType) - end - end, Opaques); type(maps, update, 3, Xs, Opaques) -> strict(maps, update, 3, Xs, fun ([Key, Value, Map]) -> @@ -1903,7 +1885,8 @@ infinity_div(Number1, Number2) when is_integer(Number1), is_integer(Number2) -> infinity_bsl(pos_inf, _) -> pos_inf; infinity_bsl(neg_inf, _) -> neg_inf; -infinity_bsl(Number, pos_inf) when is_integer(Number), Number >= 0 -> pos_inf; +infinity_bsl(0, pos_inf) -> 0; +infinity_bsl(Number, pos_inf) when is_integer(Number), Number > 0 -> pos_inf; infinity_bsl(Number, pos_inf) when is_integer(Number) -> neg_inf; infinity_bsl(Number, neg_inf) when is_integer(Number), Number >= 0 -> 0; infinity_bsl(Number, neg_inf) when is_integer(Number) -> -1; @@ -1992,9 +1975,11 @@ arith_abs(X1, Opaques) -> case infinity_geq(Min1, 0) of true -> {Min1, Max1}; false -> + NegMin1 = infinity_inv(Min1), + NegMax1 = infinity_inv(Max1), case infinity_geq(Max1, 0) of - true -> {0, infinity_inv(Min1)}; - false -> {infinity_inv(Max1), infinity_inv(Min1)} + true -> {0, max(NegMin1, Max1)}; + false -> {NegMax1, NegMin1} end end, t_from_range(NewMin, NewMax) @@ -2648,8 +2633,6 @@ arg_types(maps, put, 3) -> [t_any(), t_any(), t_map()]; arg_types(maps, size, 1) -> [t_map()]; -arg_types(maps, to_list, 1) -> - [t_map()]; arg_types(maps, update, 3) -> [t_any(), t_any(), t_map()]; arg_types(M, F, A) when is_atom(M), is_atom(F), diff --git a/lib/hipe/cerl/erl_types.erl b/lib/hipe/cerl/erl_types.erl index d8d707c05e..8a609ef911 100644 --- a/lib/hipe/cerl/erl_types.erl +++ b/lib/hipe/cerl/erl_types.erl @@ -1877,6 +1877,7 @@ t_map_put(KV, Map, Opaques) -> %% Key and Value are *not* unopaqued, but the map is map_put(_, ?none, _) -> ?none; +map_put(_, ?unit, _) -> ?none; map_put({Key, Value}, ?map(Pairs,DefK,DefV), Opaques) -> case t_is_none_or_unit(Key) orelse t_is_none_or_unit(Value) of true -> ?none; @@ -1902,6 +1903,7 @@ t_map_update(KV, Map) -> -spec t_map_update({erl_type(), erl_type()}, erl_type(), opaques()) -> erl_type(). t_map_update(_, ?none, _) -> ?none; +t_map_update(_, ?unit, _) -> ?none; t_map_update(KV={Key, _}, M, Opaques) -> case t_is_subtype(t_atom('true'), t_map_is_key(Key, M, Opaques)) of false -> ?none; @@ -1922,6 +1924,7 @@ t_map_get(Key, Map, Opaques) -> end). map_get(_, ?none) -> ?none; +map_get(_, ?unit) -> ?none; map_get(Key, ?map(Pairs, DefK, DefV)) -> DefRes = case t_do_overlap(DefK, Key) of @@ -1957,6 +1960,7 @@ t_map_is_key(Key, Map, Opaques) -> end). map_is_key(_, ?none) -> ?none; +map_is_key(_, ?unit) -> ?none; map_is_key(Key, ?map(Pairs, DefK, _DefV)) -> case is_singleton_type(Key) of true -> @@ -2347,6 +2351,8 @@ t_from_range(X, Y) -> -else. +t_from_range(pos_inf, pos_inf) -> ?integer_pos; +t_from_range(neg_inf, neg_inf) -> ?integer_neg; t_from_range(neg_inf, pos_inf) -> t_integer(); t_from_range(neg_inf, Y) when is_integer(Y), Y < 0 -> ?integer_neg; t_from_range(neg_inf, Y) when is_integer(Y), Y >= 0 -> t_integer(); @@ -2379,6 +2385,8 @@ t_from_range(pos_inf, neg_inf) -> t_none(). -spec t_from_range_unsafe(rng_elem(), rng_elem()) -> erl_type(). +t_from_range_unsafe(pos_inf, pos_inf) -> ?integer_pos; +t_from_range_unsafe(neg_inf, neg_inf) -> ?integer_neg; t_from_range_unsafe(neg_inf, pos_inf) -> t_integer(); t_from_range_unsafe(neg_inf, Y) -> ?int_range(neg_inf, Y); t_from_range_unsafe(X, pos_inf) -> ?int_range(X, pos_inf); diff --git a/lib/hipe/doc/src/Makefile b/lib/hipe/doc/src/Makefile index 63154abd6a..1c774d3357 100644 --- a/lib/hipe/doc/src/Makefile +++ b/lib/hipe/doc/src/Makefile @@ -38,7 +38,7 @@ RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) XML_APPLICATION_FILES = ref_man.xml XML_REF3_FILES = -XML_PART_FILES = +XML_PART_FILES = hipe_app.xml XML_CHAPTER_FILES = notes.xml BOOK_FILES = book.xml diff --git a/lib/hipe/doc/src/hipe_app.xml b/lib/hipe/doc/src/hipe_app.xml index e489d155c3..aaeb06193d 100644 --- a/lib/hipe/doc/src/hipe_app.xml +++ b/lib/hipe/doc/src/hipe_app.xml @@ -47,6 +47,61 @@ Details on HiPE compiler options are given by <c>hipe:help_options()</c>.</p> </description> <section> + <title>Feature Limitations</title> + <p> + The HiPE compiler is in general compliant with the normal BEAM compiler, + with respect to semantic behavior. There are however features in the BEAM compiler + and the runtime system that have limited or no support for HiPE compiled modules. + </p> + <taglist> + <tag>Stack traces</tag> + <item><p>Stack traces returned from <seealso marker="erts:erlang#get_stacktrace/0"> + <c>erlang:get_stacktrace/0</c></seealso> or as part of <c>'EXIT'</c> terms + can look incomplete if HiPE compiled functions are involved. Typically a stack trace + will contain only BEAM compiled functions or only HiPE compiled functions, depending + on where the exception was raised.</p> + <p>Source code line numbers in stack traces are also not supported by HiPE compiled functions.</p> + </item> + + <tag>Tracing</tag> + <item><p>Erlang call trace is not supported by HiPE. Calling + <seealso marker="erts:erlang#trace_pattern/3"><c>erlang:trace_pattern({M,F,A}, ...)</c></seealso> + does not have any effect on HiPE compiled modules.</p> + </item> + + <tag>NIFs</tag> + <item><p>Modules compiled with HiPE can not call <seealso marker="erts:erlang#load_nif-2"> + <c>erlang:load_nif/2</c></seealso> to load NIFs.</p> + </item> + + <tag>-on_load</tag> + <item><p>Modules compiled with HiPE can not use + <seealso marker="doc/reference_manual:code_loading#on_load"><c>-on_load()</c></seealso> + directives.</p> + </item> + </taglist> + + </section> + <section> + <title>Performance Limitations</title> + <p> + The HiPE compiler does in general produce faster code than the + BEAM compiler. There are however some situation when HiPE + compiled code will perform worse than BEAM code. + </p> + <taglist> + <tag>Mode switches</tag> + <item><p>Every time a process changes from executing code in a + HiPE compiled module to a BEAM compiled module (or vice versa), + it will do a mode switch. This involves a certain amount of + CPU overhead which can have a negative net impact if the + process is switching back and forth without getting enough done in + each mode.</p> + </item> + + </taglist> + </section> + <section> <title>SEE ALSO</title> <p> <seealso marker="stdlib:c">c(3)</seealso>, diff --git a/lib/hipe/doc/src/notes.xml b/lib/hipe/doc/src/notes.xml index eadaee50e2..bad0c254ce 100644 --- a/lib/hipe/doc/src/notes.xml +++ b/lib/hipe/doc/src/notes.xml @@ -31,6 +31,39 @@ </header> <p>This document describes the changes made to HiPE.</p> +<section><title>Hipe 3.17</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Fix bug for hipe compiled code using + <c><<X/utf32>></c> binary construction that + could cause faulty result or even VM crash.</p> + <p> + On architectures other than x86_64, code need to be + recompiled to benefit from this fix.</p> + <p> + Own Id: OTP-14740</p> + </item> + </list> + </section> + + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + Added documentation about limitations of hipe compared to + beam compiled code.</p> + <p> + Own Id: OTP-14767</p> + </item> + </list> + </section> + +</section> + <section><title>Hipe 3.16.1</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/hipe/icode/hipe_beam_to_icode.erl b/lib/hipe/icode/hipe_beam_to_icode.erl index 167f5c67bb..f429d40272 100644 --- a/lib/hipe/icode/hipe_beam_to_icode.erl +++ b/lib/hipe/icode/hipe_beam_to_icode.erl @@ -415,11 +415,13 @@ trans_fun([{wait_timeout,{_,Lbl},Reg}|Instructions], Env) -> SuspTmout = hipe_icode:mk_if(suspend_msg_timeout,[], map_label(Lbl),hipe_icode:label_name(DoneLbl)), Movs ++ [SetTmout, SuspTmout, DoneLbl | trans_fun(Instructions,Env1)]; -%%--- recv_mark/1 & recv_set/1 --- XXX: Handle better?? +%%--- recv_mark/1 & recv_set/1 --- trans_fun([{recv_mark,{f,_}}|Instructions], Env) -> - trans_fun(Instructions,Env); + Mark = hipe_icode:mk_primop([],recv_mark,[]), + [Mark | trans_fun(Instructions,Env)]; trans_fun([{recv_set,{f,_}}|Instructions], Env) -> - trans_fun(Instructions,Env); + Set = hipe_icode:mk_primop([],recv_set,[]), + [Set | trans_fun(Instructions,Env)]; %%-------------------------------------------------------------------- %%--- Translation of arithmetics {bif,ArithOp, ...} --- %%-------------------------------------------------------------------- @@ -603,6 +605,16 @@ trans_fun([{get_list,List,Head,Tail}|Instructions], Env) -> ?error_msg("hd and tl regs identical in get_list~n",[]), erlang:error(not_handled) end; +%%--- get_hd --- +trans_fun([{get_hd,List,Head}|Instructions], Env) -> + TransList = [trans_arg(List)], + I = hipe_icode:mk_primop([mk_var(Head)],unsafe_hd,TransList), + [I | trans_fun(Instructions,Env)]; +%%--- get_tl --- +trans_fun([{get_tl,List,Tail}|Instructions], Env) -> + TransList = [trans_arg(List)], + I = hipe_icode:mk_primop([mk_var(Tail)],unsafe_tl,TransList), + [I | trans_fun(Instructions,Env)]; %%--- get_tuple_element --- trans_fun([{get_tuple_element,Xreg,Index,Dst}|Instructions], Env) -> I = hipe_icode:mk_primop([mk_var(Dst)], @@ -794,7 +806,7 @@ trans_fun([{bs_append,{f,Lbl},Size,W,R,U,Binary,{field_flags,F},Dst}| SizeArg = trans_arg(Size), BinArg = trans_arg(Binary), IcodeDst = mk_var(Dst), - Offset = mk_var(reg), + Offset = mk_var(reg_gcsafe), Base = mk_var(reg), trans_bin_call({hipe_bs_primop,{bs_append,W,R,U,F}},Lbl,[SizeArg,BinArg], [IcodeDst,Base,Offset], @@ -805,7 +817,7 @@ trans_fun([{bs_private_append,{f,Lbl},Size,U,Binary,{field_flags,F},Dst}| SizeArg = trans_arg(Size), BinArg = trans_arg(Binary), IcodeDst = mk_var(Dst), - Offset = mk_var(reg), + Offset = mk_var(reg_gcsafe), Base = mk_var(reg), trans_bin_call({hipe_bs_primop,{bs_private_append,U,F}}, Lbl,[SizeArg,BinArg], @@ -844,7 +856,7 @@ trans_fun([{bs_init2,{f,Lbl},Size,_Words,_LiveRegs,{field_flags,Flags0},X}| Instructions], Env) -> Dst = mk_var(X), Flags = resolve_native_endianess(Flags0), - Offset = mk_var(reg), + Offset = mk_var(reg_gcsafe), Base = mk_var(reg), {Name, Args} = case Size of @@ -860,7 +872,7 @@ trans_fun([{bs_init_bits,{f,Lbl},Size,_Words,_LiveRegs,{field_flags,Flags0},X}| Instructions], Env) -> Dst = mk_var(X), Flags = resolve_native_endianess(Flags0), - Offset = mk_var(reg), + Offset = mk_var(reg_gcsafe), Base = mk_var(reg), {Name, Args} = case Size of @@ -1157,6 +1169,17 @@ trans_fun([{put_map_exact,{f,Lbl},Map,Dst,_N,{list,Pairs}}|Instructions], Env) - gen_put_map_instrs(new, exact, TempMapVar, Dst, new, Pairs, Env1) end, [MapMove, TempMapMove, PutInstructions | trans_fun(Instructions, Env2)]; +%%--- build_stacktrace --- +trans_fun([build_stacktrace|Instructions], Env) -> + Vars = [mk_var({x,0})], %{x,0} is implict arg and dst + [hipe_icode:mk_primop(Vars,build_stacktrace,Vars), + trans_fun(Instructions, Env)]; +%%--- raw_raise --- +trans_fun([raw_raise|Instructions], Env) -> + Vars = [mk_var({x,0}),mk_var({x,1}),mk_var({x,2})], + Dst = [mk_var({x,0})], + [hipe_icode:mk_primop(Dst,raw_raise,Vars) | + trans_fun(Instructions, Env)]; %%-------------------------------------------------------------------- %%--- ERROR HANDLING --- %%-------------------------------------------------------------------- @@ -1505,7 +1528,10 @@ clone_dst(Dest) -> New = case hipe_icode:is_reg(Dest) of true -> - mk_var(reg); + case hipe_icode:reg_is_gcsafe(Dest) of + true -> mk_var(reg_gcsafe); + false -> mk_var(reg) + end; false -> true = hipe_icode:is_var(Dest), mk_var(new) @@ -2126,7 +2152,12 @@ mk_var(reg) -> T = hipe_gensym:new_var(icode), V = (5*T)+4, hipe_gensym:update_vrange(icode,V), - hipe_icode:mk_reg(V). + hipe_icode:mk_reg(V); +mk_var(reg_gcsafe) -> + T = hipe_gensym:new_var(icode), + V = (5*T)+4, % same namespace as 'reg' + hipe_gensym:update_vrange(icode,V), + hipe_icode:mk_reg_gcsafe(V). %%----------------------------------------------------------------------- %% Make an icode label of proper type diff --git a/lib/hipe/icode/hipe_icode.erl b/lib/hipe/icode/hipe_icode.erl index 24b7ac4783..bc3403b0c5 100644 --- a/lib/hipe/icode/hipe_icode.erl +++ b/lib/hipe/icode/hipe_icode.erl @@ -515,10 +515,12 @@ annotate_variable/2, %% annotate_var_or_reg(VarOrReg, Type) unannotate_variable/1,%% unannotate_var_or_reg(VarOrReg) mk_reg/1, %% mk_reg(Id) + mk_reg_gcsafe/1, %% mk_reg_gcsafe(Id) mk_fvar/1, %% mk_fvar(Id) mk_new_var/0, %% mk_new_var() mk_new_fvar/0, %% mk_new_fvar() mk_new_reg/0, %% mk_new_reg() + mk_new_reg_gcsafe/0, %% mk_new_reg_gcsafe() mk_phi/1, %% mk_phi(Id) mk_phi/2 %% mk_phi(Id, ArgList) ]). @@ -1260,14 +1262,22 @@ is_var(_) -> false. -spec mk_reg(non_neg_integer()) -> #icode_variable{kind::'reg'}. mk_reg(V) -> #icode_variable{name=V, kind=reg}. --spec reg_name(#icode_variable{kind::'reg'}) -> non_neg_integer(). -reg_name(#icode_variable{name=Name, kind=reg}) -> Name. +-spec mk_reg_gcsafe(non_neg_integer()) -> #icode_variable{kind::'reg_gcsafe'}. +mk_reg_gcsafe(V) -> #icode_variable{name=V, kind=reg_gcsafe}. --spec reg_is_gcsafe(#icode_variable{kind::'reg'}) -> 'false'. -reg_is_gcsafe(#icode_variable{kind=reg}) -> false. % for now +-spec reg_name(#icode_variable{kind::'reg'|'reg_gcsafe'}) + -> non_neg_integer(). +reg_name(#icode_variable{name=Name, kind=reg}) -> Name; +reg_name(#icode_variable{name=Name, kind=reg_gcsafe}) -> Name. + +-spec reg_is_gcsafe(#icode_variable{kind::'reg'}) -> 'false'; + (#icode_variable{kind::'reg_gcsafe'}) -> 'true'. +reg_is_gcsafe(#icode_variable{kind=reg}) -> false; +reg_is_gcsafe(#icode_variable{kind=reg_gcsafe}) -> true. -spec is_reg(icode_argument()) -> boolean(). -is_reg(#icode_variable{kind=reg}) -> true; +is_reg(#icode_variable{kind=reg}) -> true; +is_reg(#icode_variable{kind=reg_gcsafe}) -> true; is_reg(_) -> false. -spec mk_fvar(non_neg_integer()) -> #icode_variable{kind::'fvar'}. @@ -1676,6 +1686,16 @@ mk_new_reg() -> mk_reg(hipe_gensym:get_next_var(icode)). %% +%% @doc Makes a new gcsafe register; that is, a register that is allowed to be +%% live over calls and other operations that might cause GCs and thus move heap +%% data around. +%% + +-spec mk_new_reg_gcsafe() -> icode_reg(). +mk_new_reg_gcsafe() -> + mk_reg_gcsafe(hipe_gensym:get_next_var(icode)). + +%% %% @doc Makes a new label. %% diff --git a/lib/hipe/icode/hipe_icode.hrl b/lib/hipe/icode/hipe_icode.hrl index 380ddd8371..7ed80a9ed4 100644 --- a/lib/hipe/icode/hipe_icode.hrl +++ b/lib/hipe/icode/hipe_icode.hrl @@ -41,9 +41,9 @@ -type variable_annotation() :: {atom(), any(), fun((any()) -> string())}. --record(icode_variable, {name :: non_neg_integer(), - kind :: 'var' | 'reg' | 'fvar', - annotation = [] :: [] | variable_annotation()}). +-record(icode_variable, {name :: non_neg_integer(), + kind :: 'var' | 'reg' | 'reg_gcsafe' | 'fvar', + annotation = [] :: [] | variable_annotation()}). %%--------------------------------------------------------------------- %% Type declarations for Icode instructions @@ -66,7 +66,7 @@ -type icode_funcall() :: mfa() | icode_primop(). -type icode_var() :: #icode_variable{kind::'var'}. --type icode_reg() :: #icode_variable{kind::'reg'}. +-type icode_reg() :: #icode_variable{kind::'reg'|'reg_gcsafe'}. -type icode_fvar() :: #icode_variable{kind::'fvar'}. -type icode_argument() :: #icode_const{} | #icode_variable{}. -type icode_term_arg() :: icode_var() | #icode_const{}. diff --git a/lib/hipe/icode/hipe_icode_liveness.erl b/lib/hipe/icode/hipe_icode_liveness.erl index 51e2855108..e61529a1bb 100644 --- a/lib/hipe/icode/hipe_icode_liveness.erl +++ b/lib/hipe/icode/hipe_icode_liveness.erl @@ -77,6 +77,7 @@ print_var(#icode_variable{name=V, kind=Kind, annotation=T}) -> case Kind of var -> io:format("v~p", [V]); reg -> io:format("r~p", [V]); + reg_gcsafe -> io:format("rs~p", [V]); fvar -> io:format("fv~p", [V]) end, case T of diff --git a/lib/hipe/icode/hipe_icode_pp.erl b/lib/hipe/icode/hipe_icode_pp.erl index 5b017dca32..33d1e62884 100644 --- a/lib/hipe/icode/hipe_icode_pp.erl +++ b/lib/hipe/icode/hipe_icode_pp.erl @@ -230,7 +230,10 @@ pp_arg(Dev, Arg) -> case hipe_icode:is_reg(Arg) of true -> N = hipe_icode:reg_name(Arg), - io:format(Dev, "r~p", [N]); + case hipe_icode:reg_is_gcsafe(Arg) of + true -> io:format(Dev, "rs~p", [N]); + false -> io:format(Dev, "r~p", [N]) + end; false -> N = hipe_icode:fvar_name(Arg), io:format(Dev, "fv~p", [N]) diff --git a/lib/hipe/icode/hipe_icode_primops.erl b/lib/hipe/icode/hipe_icode_primops.erl index 50ece05259..a1f1128124 100644 --- a/lib/hipe/icode/hipe_icode_primops.erl +++ b/lib/hipe/icode/hipe_icode_primops.erl @@ -67,6 +67,8 @@ is_safe(fp_mul) -> false; is_safe(fp_sub) -> false; is_safe(mktuple) -> true; is_safe(next_msg) -> false; +is_safe(recv_mark) -> false; +is_safe(recv_set) -> false; is_safe(redtest) -> false; is_safe(select_msg) -> false; is_safe(self) -> true; @@ -130,6 +132,7 @@ is_safe({hipe_bs_primop, {bs_match_string, _, _}}) -> false; is_safe({hipe_bs_primop, {bs_append, _, _, _, _}}) -> false; is_safe({hipe_bs_primop, {bs_private_append, _, _}}) -> false; is_safe({hipe_bs_primop, bs_init_writable}) -> true; +is_safe(build_stacktrace) -> true; is_safe(#mkfun{}) -> true; is_safe(#unsafe_element{}) -> true; is_safe(#unsafe_update_element{}) -> true; @@ -165,6 +168,8 @@ fails(fp_mul) -> false; fails(fp_sub) -> false; fails(mktuple) -> false; fails(next_msg) -> false; +fails(recv_mark) -> false; +fails(recv_set) -> false; fails(redtest) -> false; fails(select_msg) -> false; fails(self) -> false; @@ -230,6 +235,8 @@ fails({hipe_bs_primop, bs_final}) -> false; fails({hipe_bs_primop, {bs_append, _, _, _, _}}) -> true; fails({hipe_bs_primop, {bs_private_append, _, _}}) -> true; fails({hipe_bs_primop, bs_init_writable}) -> true; +fails(build_stacktrace) -> false; +fails(raw_raise) -> true; fails(#mkfun{}) -> false; fails(#unsafe_element{}) -> false; fails(#unsafe_update_element{}) -> false; @@ -709,6 +716,10 @@ type(Primop, Args) -> erl_types:t_any(); next_msg -> erl_types:t_any(); + recv_mark -> + erl_types:t_any(); + recv_set -> + erl_types:t_any(); select_msg -> erl_types:t_any(); set_timeout -> @@ -723,6 +734,10 @@ type(Primop, Args) -> erl_types:t_any(); debug_native_called -> erl_types:t_any(); + build_stacktrace -> + erl_types:t_list(); + raw_raise -> + erl_types:t_atom(); {M, F, A} -> erl_bif_types:type(M, F, A, Args) end. @@ -883,6 +898,10 @@ type(Primop) -> erl_types:t_any(); next_msg -> erl_types:t_any(); + recv_mark -> + erl_types:t_any(); + recv_set -> + erl_types:t_any(); select_msg -> erl_types:t_any(); set_timeout -> @@ -891,6 +910,10 @@ type(Primop) -> erl_types:t_any(); %%% ----------------------------------------------------- %%% Other + build_stacktrace -> + erl_types:t_any(); + raw_raise -> + erl_types:t_any(); #closure_element{} -> erl_types:t_any(); redtest -> diff --git a/lib/hipe/icode/hipe_icode_range.erl b/lib/hipe/icode/hipe_icode_range.erl index 287b1c80fe..34b18acccd 100644 --- a/lib/hipe/icode/hipe_icode_range.erl +++ b/lib/hipe/icode/hipe_icode_range.erl @@ -1160,6 +1160,8 @@ basic_type(#gc_test{}) -> not_analysed; %% Message handling basic_type(check_get_msg) -> not_analysed; basic_type(next_msg) -> not_analysed; +basic_type(recv_mark) -> not_analysed; +basic_type(recv_set) -> not_analysed; basic_type(select_msg) -> not_analysed; basic_type(suspend_msg) -> not_analysed; %% Functions @@ -1184,7 +1186,9 @@ basic_type(unsafe_hd) -> not_analysed; basic_type(unsafe_tl) -> not_int; basic_type(#element{}) -> not_analysed; basic_type(#unsafe_element{}) -> not_analysed; -basic_type(#unsafe_update_element{}) -> not_analysed. +basic_type(#unsafe_update_element{}) -> not_analysed; +basic_type(build_stacktrace) -> not_int; +basic_type(raw_raise) -> not_int. -spec analyse_bs_get_integer(integer(), integer(), boolean()) -> range_tuple(). diff --git a/lib/hipe/llvm/hipe_llvm.erl b/lib/hipe/llvm/hipe_llvm.erl index ccd40162cb..343ca94cb1 100644 --- a/lib/hipe/llvm/hipe_llvm.erl +++ b/lib/hipe/llvm/hipe_llvm.erl @@ -934,7 +934,7 @@ pp_ins(Dev, Ver, I) -> end, case call_is_tail(I) of true -> write(Dev, "tail "); - false -> ok + false -> write(Dev, "notail ") end, write(Dev, ["call ", call_cconv(I), " "]), pp_options(Dev, call_ret_attrs(I)), diff --git a/lib/hipe/main/hipe.app.src b/lib/hipe/main/hipe.app.src index 5b2280594f..1138d72dd2 100644 --- a/lib/hipe/main/hipe.app.src +++ b/lib/hipe/main/hipe.app.src @@ -179,6 +179,7 @@ hipe_rtl_to_sparc, hipe_rtl_to_x86, hipe_rtl_varmap, + hipe_rtl_verify_gcsafe, hipe_segment_trees, hipe_sdi, hipe_sparc, @@ -236,4 +237,4 @@ {applications, [kernel,stdlib]}, {env, []}, {runtime_dependencies, ["syntax_tools-1.6.14","stdlib-3.4","kernel-5.3", - "erts-9.0","compiler-5.0"]}]}. + "erts-9.3","compiler-5.0"]}]}. diff --git a/lib/hipe/main/hipe.erl b/lib/hipe/main/hipe.erl index f5f5bf5830..acb9b7b062 100644 --- a/lib/hipe/main/hipe.erl +++ b/lib/hipe/main/hipe.erl @@ -1414,6 +1414,7 @@ opt_keys() -> use_clusters, use_jumptable, verbose, + verify_gcsafe, %% verbose_spills, x87]. @@ -1510,7 +1511,8 @@ opt_negations() -> {no_use_callgraph, use_callgraph}, {no_use_clusters, use_clusters}, {no_use_inline_atom_search, use_inline_atom_search}, - {no_use_indexing, use_indexing}]. + {no_use_indexing, use_indexing}, + {no_verify_gcsafe, verify_gcsafe}]. %% Don't use negative forms in right-hand sides of aliases and expansions! %% We only expand negations once, before the other expansions are done. diff --git a/lib/hipe/main/hipe_main.erl b/lib/hipe/main/hipe_main.erl index dca6fddec3..6e48f0cffd 100644 --- a/lib/hipe/main/hipe_main.erl +++ b/lib/hipe/main/hipe_main.erl @@ -410,6 +410,11 @@ icode_to_rtl(MFA, Icode, Options, Servers) -> hipe_llvm_liveness:analyze(RtlCfg4) end, pp(RtlCfg5, MFA, rtl, pp_rtl, Options, Servers), + case proplists:get_bool(no_verify_gcsafe, Options) of + true -> ok; + false -> + ok = hipe_rtl_verify_gcsafe:check(RtlCfg5) + end, LinearRTL1 = hipe_rtl_cfg:linearize(RtlCfg5), LinearRTL2 = hipe_rtl_cleanup_const:cleanup(LinearRTL1), %% hipe_rtl:pp(standard_io, LinearRTL2), diff --git a/lib/hipe/rtl/Makefile b/lib/hipe/rtl/Makefile index 5abc9ec049..becdd0b7d8 100644 --- a/lib/hipe/rtl/Makefile +++ b/lib/hipe/rtl/Makefile @@ -50,7 +50,7 @@ HIPE_MODULES = hipe_rtl hipe_rtl_cfg \ hipe_rtl_ssa hipe_rtl_ssa_const_prop \ hipe_rtl_cleanup_const hipe_rtl_symbolic hipe_rtl_lcm \ hipe_rtl_ssapre hipe_rtl_binary hipe_rtl_ssa_avail_expr \ - hipe_rtl_arch hipe_tagscheme + hipe_rtl_arch hipe_tagscheme hipe_rtl_verify_gcsafe else HIPE_MODULES = endif diff --git a/lib/hipe/rtl/hipe_rtl.erl b/lib/hipe/rtl/hipe_rtl.erl index 04c9728d5c..33027f3259 100644 --- a/lib/hipe/rtl/hipe_rtl.erl +++ b/lib/hipe/rtl/hipe_rtl.erl @@ -1740,7 +1740,10 @@ pp_reg(Dev, Arg) -> true -> pp_hard_reg(Dev, reg_index(Arg)); false -> - io:format(Dev, "r~w", [reg_index(Arg)]) + case reg_is_gcsafe(Arg) of + true -> io:format(Dev, "rs~w", [reg_index(Arg)]); + false -> io:format(Dev, "r~w", [reg_index(Arg)]) + end end. pp_var(Dev, Arg) -> diff --git a/lib/hipe/rtl/hipe_rtl_binary_construct.erl b/lib/hipe/rtl/hipe_rtl_binary_construct.erl index 52ea5db382..111dda3d82 100644 --- a/lib/hipe/rtl/hipe_rtl_binary_construct.erl +++ b/lib/hipe/rtl/hipe_rtl_binary_construct.erl @@ -168,9 +168,13 @@ gen_rtl(BsOP, Dst, Args, TrueLblName, FalseLblName, SystemLimitLblName, ConstTab bs_put_utf8 -> [_Src, _Base, _Offset] = Args, - NewDsts = get_real(Dst), - [hipe_rtl:mk_call(NewDsts, bs_put_utf8, Args, - TrueLblName, FalseLblName, not_remote)]; + [NewOffs] = get_real(Dst), + RetLbl = hipe_rtl:mk_new_label(), + [hipe_rtl:mk_call([NewOffs], bs_put_utf8, Args, + hipe_rtl:label_name(RetLbl), [], not_remote), + RetLbl, + hipe_rtl:mk_branch(NewOffs, ne, hipe_rtl:mk_imm(0), + TrueLblName, FalseLblName, 0.99)]; bs_utf16_size -> case Dst of @@ -195,8 +199,13 @@ gen_rtl(BsOP, Dst, Args, TrueLblName, FalseLblName, SystemLimitLblName, ConstTab bs_validate_unicode -> [_Arg] = Args, - [hipe_rtl:mk_call([], bs_validate_unicode, Args, - TrueLblName, FalseLblName, not_remote)]; + [IsUnicode] = create_regs(1), + RetLbl = hipe_rtl:mk_new_label(), + [hipe_rtl:mk_call([IsUnicode], is_unicode, Args, + hipe_rtl:label_name(RetLbl), [], not_remote), + RetLbl, + hipe_rtl:mk_branch(IsUnicode, ne, hipe_rtl:mk_imm(0), + TrueLblName, FalseLblName, 0.99)]; bs_final -> Zero = hipe_rtl:mk_imm(0), @@ -354,7 +363,8 @@ not_writable_code(Bin, SizeReg, Dst, Base, Offset, Unit, allocate_writable(Dst, Base, UsedBytes, TotBytes, TotSize) -> Zero = hipe_rtl:mk_imm(0), [NextLbl] = create_lbls(1), - [EndSubSize, EndSubBitSize, ProcBin] = create_regs(3), + [EndSubSize, EndSubBitSize] = create_regs(2), + [ProcBin] = create_unsafe_regs(1), [hipe_rtl:mk_call([Base], bs_allocate, [UsedBytes], hipe_rtl:label_name(NextLbl), [], not_remote), NextLbl, @@ -581,12 +591,12 @@ const_init2(Size, Dst, Base, Offset, TrueLblName) -> false -> ByteSize = hipe_rtl:mk_new_reg(), [hipe_rtl:mk_gctest(?PROC_BIN_WORDSIZE+?SUB_BIN_WORDSIZE), - hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)), hipe_rtl:mk_move(ByteSize, hipe_rtl:mk_imm(Size)), hipe_rtl:mk_call([Base], bs_allocate, [ByteSize], hipe_rtl:label_name(NextLbl), [], not_remote), NextLbl, hipe_tagscheme:create_refc_binary(Base, ByteSize, Dst), + hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)), hipe_rtl:mk_goto(TrueLblName)] end. @@ -629,13 +639,12 @@ var_init2(Size, Dst, Base, Offset, TrueLblName, SystemLimitLblName, FalseLblName Log2WordSize = hipe_rtl_arch:log2_word_size(), WordSize = hipe_rtl_arch:word_size(), [ContLbl, HeapLbl, REFCLbl, NextLbl] = create_lbls(4), - [USize, Tmp] = create_unsafe_regs(2), + [USize, Tmp] = create_regs(2), [get_word_integer(Size, USize, SystemLimitLblName, FalseLblName), hipe_rtl:mk_branch(USize, leu, hipe_rtl:mk_imm(?MAX_BINSIZE), hipe_rtl:label_name(ContLbl), SystemLimitLblName), ContLbl, - hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)), hipe_rtl:mk_branch(USize, leu, hipe_rtl:mk_imm(?MAX_HEAP_BIN_SIZE), hipe_rtl:label_name(HeapLbl), hipe_rtl:label_name(REFCLbl)), @@ -645,6 +654,7 @@ var_init2(Size, Dst, Base, Offset, TrueLblName, SystemLimitLblName, FalseLblName hipe_rtl:mk_alu(Tmp, Tmp, add, hipe_rtl:mk_imm(?SUB_BIN_WORDSIZE)), hipe_rtl:mk_gctest(Tmp), hipe_tagscheme:create_heap_binary(Base, USize, Dst), + hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)), hipe_rtl:mk_goto(TrueLblName), REFCLbl, hipe_rtl:mk_gctest(?PROC_BIN_WORDSIZE+?SUB_BIN_WORDSIZE), @@ -652,6 +662,7 @@ var_init2(Size, Dst, Base, Offset, TrueLblName, SystemLimitLblName, FalseLblName hipe_rtl:label_name(NextLbl), [], not_remote), NextLbl, hipe_tagscheme:create_refc_binary(Base, USize, Dst), + hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)), hipe_rtl:mk_goto(TrueLblName)]. var_init_bits(Size, Dst, Base, Offset, TrueLblName, SystemLimitLblName, FalseLblName) -> @@ -858,7 +869,7 @@ get_base_offset_size(Binary, SrcBase, SrcOffset, SrcSize, FLName) -> JoinLbl, hipe_tagscheme:test_heap_binary(Orig, HeapLblName, REFCLblName), HeapLbl, - hipe_rtl:mk_alu(SrcBase, Orig, add, hipe_rtl:mk_imm(?HEAP_BIN_DATA-2)), + hipe_tagscheme:get_field_addr_from_term({heap_bin, {data, 0}}, Orig, SrcBase), hipe_rtl:mk_goto(EndLblName), REFCLbl, hipe_tagscheme:get_field_from_term({proc_bin,bytes}, Orig, SrcBase), @@ -1205,6 +1216,12 @@ is_divisible(Dividend, Divisor, SuccLbl, FailLbl) -> [hipe_rtl:mk_branch(Dividend, 'and', Mask, eq, SuccLbl, FailLbl, 0.99)]; false -> %% We need division, fall back to a primop - [hipe_rtl:mk_call([], is_divisible, [Dividend, hipe_rtl:mk_imm(Divisor)], - SuccLbl, FailLbl, not_remote)] + [Tmp] = create_regs(1), + RetLbl = hipe_rtl:mk_new_label(), + [hipe_rtl:mk_call([Tmp], is_divisible, + [Dividend, hipe_rtl:mk_imm(Divisor)], + hipe_rtl:label_name(RetLbl), [], not_remote), + RetLbl, + hipe_rtl:mk_branch(Tmp, ne, hipe_rtl:mk_imm(0), + SuccLbl, FailLbl, 0.99)] end. diff --git a/lib/hipe/rtl/hipe_rtl_binary_match.erl b/lib/hipe/rtl/hipe_rtl_binary_match.erl index 362a52f8fe..4575213838 100644 --- a/lib/hipe/rtl/hipe_rtl_binary_match.erl +++ b/lib/hipe/rtl/hipe_rtl_binary_match.erl @@ -730,7 +730,7 @@ get_base(Orig,Base) -> [hipe_tagscheme:test_heap_binary(Orig, hipe_rtl:label_name(HeapLbl), hipe_rtl:label_name(REFCLbl)), HeapLbl, - hipe_rtl:mk_alu(Base, Orig, 'add', hipe_rtl:mk_imm(?HEAP_BIN_DATA-2)), + hipe_tagscheme:get_field_addr_from_term({heap_bin, {data, 0}}, Orig, Base), hipe_rtl:mk_goto(hipe_rtl:label_name(EndLbl)), REFCLbl, get_field_from_term({proc_bin, flags}, Orig, Flags), @@ -740,7 +740,7 @@ get_base(Orig,Base) -> WritableLbl, hipe_rtl:mk_call([], emasculate_binary, [Orig], [], [], 'not_remote'), NotWritableLbl, - hipe_rtl:mk_load(Base, Orig, hipe_rtl:mk_imm(?PROC_BIN_BYTES-2)), + get_field_from_term({proc_bin, bytes}, Orig, Base), EndLbl]. extract_matchstate_var(binsize, Ms) -> @@ -842,12 +842,12 @@ make_dyn_prep(SizeReg, CCode) -> %%------------------------------------------------------------------------ get_unaligned_int(Dst1, Size, Base, Offset, Shiftr, Type, TrueLblName) -> - [Reg] = create_regs(1), + [Reg] = create_gcsafe_regs(1), [get_maybe_unaligned_int_to_reg(Reg, Size, Base, Offset, Shiftr, Type), do_bignum_code(Size, Type, Reg, Dst1, TrueLblName)]. get_maybe_unaligned_int_to_reg(Reg, Size, Base, Offset, Shiftr, Type) -> - [LowBits] = create_regs(1), + [LowBits] = create_gcsafe_regs(1), [AlignedLbl, UnAlignedLbl, EndLbl] = create_lbls(3), [hipe_rtl:mk_alub(LowBits, Offset, 'and', hipe_rtl:mk_imm(?LOW_BITS), eq, hipe_rtl:label_name(AlignedLbl), @@ -1001,7 +1001,7 @@ do_bignum_code(Size, {Signedness,_}, Src, Dst1, TrueLblName) end. signed_bignum(Dst1, Src, TrueLblName) -> - Tmp1 = hipe_rtl:mk_new_reg(), + Tmp1 = hipe_rtl:mk_new_reg_gcsafe(), BignumLabel = hipe_rtl:mk_new_label(), [hipe_tagscheme:realtag_fixnum(Dst1, Src), hipe_tagscheme:realuntag_fixnum(Tmp1, Dst1), diff --git a/lib/hipe/rtl/hipe_rtl_cleanup_const.erl b/lib/hipe/rtl/hipe_rtl_cleanup_const.erl index bfa6b9682e..00cc2bcb37 100644 --- a/lib/hipe/rtl/hipe_rtl_cleanup_const.erl +++ b/lib/hipe/rtl/hipe_rtl_cleanup_const.erl @@ -69,9 +69,9 @@ cleanup_instr([Const|Left], I, Acc) -> case I of X when is_record(X, fp_unop) orelse is_record(X, fp) -> Fdst = hipe_rtl:mk_new_fpreg(), - Fconv = hipe_tagscheme:unsafe_untag_float(Fdst, Dst), + Fconv = lists:flatten(hipe_tagscheme:unsafe_untag_float(Fdst, Dst)), NewI = hipe_rtl:subst_uses([{Const, Fdst}], I), - cleanup_instr(Left, NewI, Fconv ++ [Load|Acc]); + cleanup_instr(Left, NewI, lists:reverse(Fconv, [Load|Acc])); _ -> NewI = hipe_rtl:subst_uses([{Const, Dst}], I), cleanup_instr(Left, NewI, [Load|Acc]) diff --git a/lib/hipe/rtl/hipe_rtl_lcm.erl b/lib/hipe/rtl/hipe_rtl_lcm.erl index 9dcdd05fb1..af39c9a0a4 100644 --- a/lib/hipe/rtl/hipe_rtl_lcm.erl +++ b/lib/hipe/rtl/hipe_rtl_lcm.erl @@ -182,42 +182,41 @@ delete_exprs(Code, _, _, []) -> Code; delete_exprs(Code, ExprMap, IdMap, [ExprId|Exprs]) -> Expr = expr_id_map_get_expr(IdMap, ExprId), - %% Perform a foldl that goes through the code and deletes all - %% occurences of the expression. - NewCode = - lists:reverse - (lists:foldl(fun(CodeExpr, Acc) -> - case is_expr(CodeExpr) of - true -> - case expr_clear_dst(CodeExpr) =:= Expr of - true -> - pp_debug(" Deleting: ", []), - pp_debug_instr(CodeExpr), - %% Lookup expression entry. - Defines = - case expr_map_lookup(ExprMap, Expr) of - {value, {_, _, Defs}} -> - Defs; - none -> - exit({?MODULE, expr_map_lookup, - "expression missing"}) - end, - MoveCode = - mk_expr_move_instr(hipe_rtl:defines(CodeExpr), - Defines), - pp_debug(" Replacing with: ", []), - pp_debug_instr(MoveCode), - [MoveCode|Acc]; - false -> - [CodeExpr|Acc] - end; - false -> - [CodeExpr|Acc] - end - end, - [], Code)), + %% Lookup expression entry. + {value, {_, _, Defines}} = expr_map_lookup(ExprMap, Expr), + %% Go through the code and deletes all occurences of the expression. + NewCode = delete_expr(Code, Expr, Defines, []), delete_exprs(NewCode, ExprMap, IdMap, Exprs). +delete_expr([], _Expr, _Defines, Acc) -> lists:reverse(Acc); +delete_expr([CodeExpr|Code], Expr, Defines, Acc) -> + case exp_kill_expr(CodeExpr, [Expr]) of + [] -> % Expr was killed; deleting stops here + pp_debug(" Stopping before: ", []), + pp_debug_instr(CodeExpr), + lists:reverse(Acc, [CodeExpr|Code]); + [Expr] -> + NewCodeExpr = + case is_expr(CodeExpr) of + true -> + case expr_clear_dst(CodeExpr) =:= Expr of + true -> + pp_debug(" Deleting: ", []), + pp_debug_instr(CodeExpr), + MoveCode = mk_expr_move_instr(hipe_rtl:defines(CodeExpr), + Defines), + pp_debug(" Replacing with: ", []), + pp_debug_instr(MoveCode), + MoveCode; + false -> + CodeExpr + end; + false -> + CodeExpr + end, + delete_expr(Code, Expr, Defines, [NewCodeExpr|Acc]) + end. + %%============================================================================= %% Goes through the given list of expressions and inserts them at %% appropriate places in the code. @@ -226,13 +225,12 @@ insert_exprs(CFG, _, _, _, _, BetweenMap, []) -> insert_exprs(CFG, Pred, Succ, ExprMap, IdMap, BetweenMap, [ExprId|Exprs]) -> Expr = expr_id_map_get_expr(IdMap, ExprId), Instr = expr_map_get_instr(ExprMap, Expr), - case hipe_rtl_cfg:succ(CFG, Pred) of - [_] -> + case try_insert_expr_last(CFG, Pred, Instr) of + {ok, NewCFG} -> pp_debug(" Inserted last: ", []), pp_debug_instr(Instr), - NewCFG = insert_expr_last(CFG, Pred, Instr), insert_exprs(NewCFG, Pred, Succ, ExprMap, IdMap, BetweenMap, Exprs); - _ -> + not_safe -> case hipe_rtl_cfg:pred(CFG, Succ) of [_] -> pp_debug(" Inserted first: ", []), @@ -252,25 +250,31 @@ insert_exprs(CFG, Pred, Succ, ExprMap, IdMap, BetweenMap, [ExprId|Exprs]) -> %% Recursively goes through the code in a block and returns a new block %% with the new code inserted second to last (assuming the last expression %% is a branch operation). -insert_expr_last(CFG0, Label, Instr) -> - Code0 = hipe_bb:code(hipe_rtl_cfg:bb(CFG0, Label)), - %% FIXME: Use hipe_bb:butlast() instead? - Code1 = insert_expr_last_work(Label, Instr, Code0), - hipe_rtl_cfg:bb_add(CFG0, Label, hipe_bb:mk_bb(Code1)). +try_insert_expr_last(CFG0, Label, Instr) -> + case hipe_rtl_cfg:succ(CFG0, Label) of + [_] -> + Code0 = hipe_bb:code(hipe_rtl_cfg:bb(CFG0, Label)), + case insert_expr_last_work(Instr, Code0) of + not_safe -> not_safe; + Code1 -> + {ok, hipe_rtl_cfg:bb_add(CFG0, Label, hipe_bb:mk_bb(Code1))} + end; + _ -> not_safe + end. %%============================================================================= %% Recursively goes through the code in a block and returns a new block %% with the new code inserted second to last (assuming the last expression %% is a branch operation). -insert_expr_last_work(_, Instr, []) -> - %% This case should not happen since this means that block was completely - %% empty when the function was called. For compatibility we insert it last. - [Instr]; -insert_expr_last_work(_, Instr, [Code1]) -> +insert_expr_last_work(_Instr, [#call{}]) -> + %% Call instructions clobber all expressions; we musn't insert the expression + %% before it + not_safe; +insert_expr_last_work(Instr, [Code1]) -> %% We insert the code next to last. [Instr, Code1]; -insert_expr_last_work(Label, Instr, [Code|Codes]) -> - [Code|insert_expr_last_work(Label, Instr, Codes)]. +insert_expr_last_work(Instr, [Code|Codes]) -> + [Code|insert_expr_last_work(Instr, Codes)]. %%============================================================================= %% Inserts expression first in the block for the given label. @@ -305,7 +309,8 @@ insert_expr_between(CFG0, BetweenMap, Pred, Succ, Instr) -> {value, Label} -> pp_debug(" Using existing new bb for edge (~w,~w) with label ~w~n", [Pred, Succ, Label]), - {insert_expr_last(CFG0, Label, Instr), BetweenMap} + {ok, NewCfg} = try_insert_expr_last(CFG0, Label, Instr), + {NewCfg, BetweenMap} end. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/lib/hipe/rtl/hipe_rtl_primops.erl b/lib/hipe/rtl/hipe_rtl_primops.erl index 850a75f71b..ce5433379e 100644 --- a/lib/hipe/rtl/hipe_rtl_primops.erl +++ b/lib/hipe/rtl/hipe_rtl_primops.erl @@ -291,6 +291,10 @@ gen_primop({Op,Dst,Args,Cont,Fail}, IsGuard, ConstTab) -> gen_select_msg(Dst, Cont); clear_timeout -> gen_clear_timeout(Dst, GotoCont); + recv_mark -> + gen_recv_mark(Dst, GotoCont); + recv_set -> + gen_recv_set(Dst, Cont); set_timeout -> %% BIF call: am_set_timeout -> nbif_set_timeout -> hipe_set_timeout [hipe_rtl:mk_call(Dst, set_timeout, Args, Cont, Fail, not_remote)]; @@ -390,6 +394,10 @@ gen_primop({Op,Dst,Args,Cont,Fail}, IsGuard, ConstTab) -> end; debug_native_called -> [hipe_rtl:mk_call(Dst, Op, Args, Cont, Fail, not_remote)]; + build_stacktrace -> + [hipe_rtl:mk_call(Dst, Op, Args, Cont, Fail, not_remote)]; + raw_raise -> + [hipe_rtl:mk_call(Dst, Op, Args, Cont, Fail, not_remote)]; %% Only names listed above are accepted! MFA:s are not primops! _ -> @@ -1064,6 +1072,27 @@ gen_tuple_header(Ptr, Arity) -> %%% %%% Receives +%%% recv_mark is: +%%% p->msg.saved_last = p->msg.last; +gen_recv_mark([], GotoCont) -> + TmpLast = hipe_rtl:mk_new_reg(), + [load_p_field(TmpLast, ?P_MSG_LAST), + store_p_field(TmpLast, ?P_MSG_SAVED_LAST), + GotoCont]. + +%%% recv_set is: +%%% if (p->msg.saved_last) +%%% p->msg.save = p->msg.saved_last; +gen_recv_set([], Cont) -> + TmpSave = hipe_rtl:mk_new_reg(), + TrueLbl = hipe_rtl:mk_new_label(), + [load_p_field(TmpSave, ?P_MSG_SAVED_LAST), + hipe_rtl:mk_branch(TmpSave, ne, hipe_rtl:mk_imm(0), + hipe_rtl:label_name(TrueLbl), Cont), + TrueLbl, + store_p_field(TmpSave, ?P_MSG_SAVE), + hipe_rtl:mk_goto(Cont)]. + gen_check_get_msg(Dsts, GotoCont, Fail) -> gen_check_get_msg_outofline(Dsts, GotoCont, Fail). diff --git a/lib/hipe/rtl/hipe_rtl_varmap.erl b/lib/hipe/rtl/hipe_rtl_varmap.erl index 375a8f85c0..f34c66ab85 100644 --- a/lib/hipe/rtl/hipe_rtl_varmap.erl +++ b/lib/hipe/rtl/hipe_rtl_varmap.erl @@ -105,7 +105,7 @@ icode_var2rtl_var(Var, Map) -> {reg, IsGcSafe} -> NewVar = case IsGcSafe of - %% true -> hipe_rtl:mk_new_reg_gcsafe(); + true -> hipe_rtl:mk_new_reg_gcsafe(); false -> hipe_rtl:mk_new_reg() end, {NewVar, insert(Var, NewVar, Map)} diff --git a/lib/hipe/rtl/hipe_rtl_verify_gcsafe.erl b/lib/hipe/rtl/hipe_rtl_verify_gcsafe.erl new file mode 100644 index 0000000000..01d7e89ccd --- /dev/null +++ b/lib/hipe/rtl/hipe_rtl_verify_gcsafe.erl @@ -0,0 +1,89 @@ +%% -*- mode: erlang; erlang-indent-level: 2 -*- +%% +%% 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. +%% +-module(hipe_rtl_verify_gcsafe). + +-export([check/1]). + +-include("../flow/cfg.hrl"). %% needed for the specs +-include("hipe_rtl.hrl"). + +check(CFG) -> + Liveness = hipe_rtl_liveness:analyze(CFG), + put({?MODULE, 'fun'}, CFG#cfg.info#cfg_info.'fun'), + lists:foreach( + fun(Lb) -> + put({?MODULE, label}, Lb), + Liveout = hipe_rtl_liveness:liveout(Liveness, Lb), + BB = hipe_rtl_cfg:bb(CFG, Lb), + check_instrs(lists:reverse(hipe_bb:code(BB)), Liveout) + end, hipe_rtl_cfg:labels(CFG)), + erase({?MODULE, 'fun'}), + erase({?MODULE, label}), + erase({?MODULE, instr}), + ok. + +check_instrs([], _Livein) -> ok; +check_instrs([I|Is], LiveOut) -> + Def = ordsets:from_list(hipe_rtl:defines(I)), + Use = ordsets:from_list(hipe_rtl:uses(I)), + LiveOver = ordsets:subtract(LiveOut, Def), + LiveIn = ordsets:union(LiveOver, Use), + case (hipe_rtl:is_call(I) + andalso not safe_primop(hipe_rtl:call_fun(I))) + orelse is_record(I, gctest) + of + false -> ok; + true -> + put({?MODULE, instr}, I), + lists:foreach(fun verify_live/1, LiveOver) + end, + check_instrs(Is, LiveIn). + +verify_live(T) -> + case hipe_rtl:is_reg(T) of + false -> ok; + true -> + case hipe_rtl:reg_is_gcsafe(T) of + true -> ok; + false -> + error({gcunsafe_live_over_call, + get({?MODULE, 'fun'}), + {label, get({?MODULE, label})}, + get({?MODULE, instr}), + T}) + end + end. + +%% Primops that can't gc +%% Note: This information is essentially duplicated from hipe_bif_list.m4 +safe_primop(is_divisible) -> true; +safe_primop(is_unicode) -> true; +safe_primop(cmp_2) -> true; +safe_primop(eq_2) -> true; +safe_primop(bs_allocate) -> true; +safe_primop(bs_reallocate) -> true; +safe_primop(bs_utf8_size) -> true; +safe_primop(bs_get_utf8) -> true; +safe_primop(bs_put_utf8) -> true; +safe_primop(bs_utf16_size) -> true; +safe_primop(bs_get_utf16) -> true; +safe_primop(bs_validate_unicode_retract) -> true; +safe_primop(bs_put_small_float) -> true; +safe_primop(bs_put_bits) -> true; +safe_primop(emasculate_binary) -> true; +safe_primop(atomic_inc) -> true; +%% Not noproc but manually verified +safe_primop(bs_put_big_integer) -> true; +safe_primop(_) -> false. diff --git a/lib/hipe/rtl/hipe_tagscheme.erl b/lib/hipe/rtl/hipe_tagscheme.erl index 68cbe75e85..737f0ec5e3 100644 --- a/lib/hipe/rtl/hipe_tagscheme.erl +++ b/lib/hipe/rtl/hipe_tagscheme.erl @@ -53,7 +53,8 @@ -export([test_subbinary/3, test_heap_binary/3]). -export([create_heap_binary/3, create_refc_binary/3, create_refc_binary/4]). -export([create_matchstate/6, convert_matchstate/1, compare_matchstate/4]). --export([get_field_from_term/3, get_field_from_pointer/3, +-export([get_field_addr_from_term/3, + get_field_from_term/3, get_field_from_pointer/3, set_field_from_term/3, set_field_from_pointer/3, extract_matchbuffer/2, extract_binary_bytes/2]). @@ -76,6 +77,10 @@ -define(TAG_PRIMARY_BOXED, 16#2). -define(TAG_PRIMARY_IMMED1, 16#3). +%% Only when ?ERTS_USE_LITERAL_TAG =:= 1 +-define(TAG_PTR_MASK__, 16#7). +-define(TAG_LITERAL_PTR, 16#4). + -define(TAG_IMMED1_SIZE, 4). -define(TAG_IMMED1_MASK, 16#F). -define(TAG_IMMED1_PID, ((16#0 bsl ?TAG_PRIMARY_SIZE) bor ?TAG_PRIMARY_IMMED1)). @@ -157,6 +162,38 @@ tag_cons(Res, X) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +ptr_val(Res, X) -> + hipe_rtl:mk_alu(Res, X, 'and', hipe_rtl:mk_imm(bnot ?TAG_PTR_MASK__)). + +%% Returns {Base, Offset, Untag}. To be used like, for example: +%% {Base, Offset, Untag} = untag_ptr(X, ?TAG_PRIMARY_BOXED), +%% ... +%% [Untag, hipe_rtl:mk_load(Dst, Base, hipe_rtl:mk_imm(Offset))]. +%% +%% NB: Base might either be X or a new temp. It must thus not be modified. +untag_ptr(X, Tag) -> + case ?ERTS_USE_LITERAL_TAG of + 0 -> + {X, -Tag, []}; + 1 -> + Base = hipe_rtl:mk_new_reg(), + Untag = ptr_val(Base, X), + {Base, 0, Untag} + end. + +untag_ptr_nooffset(Dst, X, Tag) -> + %% We could just use ptr_val in all cases, but subtraction can use LEA on x86 + %% and can be inlined into effective address computations on several + %% architectures. + case ?ERTS_USE_LITERAL_TAG of + 0 -> + hipe_rtl:mk_alu(Dst, X, 'sub', hipe_rtl:mk_imm(Tag)); + 1 -> + ptr_val(Dst, X) + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + %%% Operations to test if an object has a known type T. test_nil(X, TrueLab, FalseLab, Pred) -> @@ -171,7 +208,8 @@ test_is_boxed(X, TrueLab, FalseLab, Pred) -> hipe_rtl:mk_branch(X, 'and', Mask, 'eq', TrueLab, FalseLab, Pred). get_header(Res, X) -> - hipe_rtl:mk_load(Res, X, hipe_rtl:mk_imm(-(?TAG_PRIMARY_BOXED))). + {Base, Offset, Untag} = untag_ptr(X, ?TAG_PRIMARY_BOXED), + [Untag, hipe_rtl:mk_load(Res, Base, hipe_rtl:mk_imm(Offset))]. mask_and_compare(X, Mask, Value, TrueLab, FalseLab, Pred) -> Tmp = hipe_rtl:mk_new_reg_gcsafe(), @@ -617,21 +655,25 @@ test_either_immed(Arg1, Arg2, TrueLab, FalseLab) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% unsafe_car(Dst, Arg) -> - hipe_rtl:mk_load(Dst, Arg, hipe_rtl:mk_imm(-(?TAG_PRIMARY_LIST))). + {Base, Offset, Untag} = untag_ptr(Arg, ?TAG_PRIMARY_LIST), + [Untag, hipe_rtl:mk_load(Dst, Base, hipe_rtl:mk_imm(Offset))]. unsafe_cdr(Dst, Arg) -> + {Base, Offset, Untag} = untag_ptr(Arg, ?TAG_PRIMARY_LIST), WordSize = hipe_rtl_arch:word_size(), - hipe_rtl:mk_load(Dst, Arg, hipe_rtl:mk_imm(-(?TAG_PRIMARY_LIST)+WordSize)). + [Untag, hipe_rtl:mk_load(Dst, Base, hipe_rtl:mk_imm(Offset+WordSize))]. unsafe_constant_element(Dst, Index, Tuple) -> % Index is an immediate WordSize = hipe_rtl_arch:word_size(), - Offset = -(?TAG_PRIMARY_BOXED) + WordSize * hipe_rtl:imm_value(Index), - hipe_rtl:mk_load(Dst, Tuple, hipe_rtl:mk_imm(Offset)). + {Base, Offset0, Untag} = untag_ptr(Tuple, ?TAG_PRIMARY_BOXED), + Offset = Offset0 + WordSize * hipe_rtl:imm_value(Index), + [Untag, hipe_rtl:mk_load(Dst, Base, hipe_rtl:mk_imm(Offset))]. unsafe_update_element(Tuple, Index, Value) -> % Index is an immediate WordSize = hipe_rtl_arch:word_size(), - Offset = -(?TAG_PRIMARY_BOXED) + WordSize * hipe_rtl:imm_value(Index), - hipe_rtl:mk_store(Tuple, hipe_rtl:mk_imm(Offset), Value). + {Base, Offset0, Untag} = untag_ptr(Tuple, ?TAG_PRIMARY_BOXED), + Offset = Offset0 + WordSize * hipe_rtl:imm_value(Index), + [Untag, hipe_rtl:mk_store(Base, hipe_rtl:mk_imm(Offset), Value)]. %%% wrong semantics %% unsafe_variable_element(Dst, Index, Tuple) -> % Index is an unknown fixnum @@ -644,10 +686,12 @@ unsafe_update_element(Tuple, Index, Value) -> % Index is an immediate %% Tmp1 = hipe_rtl:mk_new_reg_gcsafe(), %% Tmp2 = hipe_rtl:mk_new_reg_gcsafe(), %% Shift = ?TAG_IMMED1_SIZE - 2, -%% OffAdj = (?TAG_IMMED1_SMALL bsr Shift) + ?TAG_PRIMARY_BOXED, +%% {Base, Off0, Untag} = untag_ptr(Tuple, ?TAG_PRIMARY_BOXED), +%% OffAdj = (?TAG_IMMED1_SMALL bsr Shift) - Off0, %% [hipe_rtl:mk_alu(Tmp1, Index, 'srl', hipe_rtl:mk_imm(Shift)), %% hipe_rtl:mk_alu(Tmp2, Tmp1, 'sub', hipe_rtl:mk_imm(OffAdj)), -%% hipe_rtl:mk_load(Dst, Tuple, Tmp2)]. +%% Untag, +%% hipe_rtl:mk_load(Base, Tuple, Tmp2)]. element(Dst, Index, Tuple, FailLabName, {tuple, A}, IndexInfo) -> FixnumOkLab = hipe_rtl:mk_new_label(), @@ -660,7 +704,7 @@ element(Dst, Index, Tuple, FailLabName, {tuple, A}, IndexInfo) -> Offset = hipe_rtl:mk_new_reg_gcsafe(), Ptr = hipe_rtl:mk_new_reg(), % offset from Tuple [untag_fixnum(UIndex, Index), - hipe_rtl:mk_alu(Ptr, Tuple, 'sub', hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED)), + untag_ptr_nooffset(Ptr, Tuple, ?TAG_PRIMARY_BOXED), hipe_rtl:mk_alu(Offset, UIndex, 'sll', hipe_rtl:mk_imm(hipe_rtl_arch:log2_word_size())), hipe_rtl:mk_load(Dst, Ptr, Offset)]; @@ -769,7 +813,7 @@ gen_element_tail(Dst, Tuple, Arity, UIndex, FailLabName, IndexOkLab) -> hipe_rtl:mk_branch(ZeroIndex, 'geu', Arity, FailLabName, hipe_rtl:label_name(IndexOkLab), 0.01), IndexOkLab, - hipe_rtl:mk_alu(Ptr, Tuple, 'sub', hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED)), + untag_ptr_nooffset(Ptr, Tuple, ?TAG_PRIMARY_BOXED), hipe_rtl:mk_alu(Offset, UIndex, 'sll', hipe_rtl:mk_imm(hipe_rtl_arch:log2_word_size())), hipe_rtl:mk_load(Dst, Ptr, Offset)]. @@ -777,11 +821,13 @@ gen_element_tail(Dst, Tuple, Arity, UIndex, FailLabName, IndexOkLab) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% unsafe_closure_element(Dst, Index, Closure) -> % Index is an immediate - Offset = -(?TAG_PRIMARY_BOXED) %% Untag + %% XXX: Can there even be closure literals? + {Base, Offset0, Untag} = untag_ptr(Closure, ?TAG_PRIMARY_BOXED), + Offset = Offset0 %% Untag + ?EFT_ENV %% Field offset %% Index from 1 to N hence -1) + (hipe_rtl_arch:word_size() * (hipe_rtl:imm_value(Index)-1)), - hipe_rtl:mk_load(Dst, Closure, hipe_rtl:mk_imm(Offset)). + [Untag, hipe_rtl:mk_load(Dst, Base, hipe_rtl:mk_imm(Offset))]. mk_fun_header() -> hipe_rtl:mk_imm(?HEADER_FUN). @@ -790,7 +836,7 @@ tag_fun(Res, X) -> tag_boxed(Res, X). %% untag_fun(Res, X) -> -%% hipe_rtl:mk_alu(Res, X, 'sub', hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED)). +%% untag_ptr_nooffset(Res, X, ?TAG_PRIMARY_BOXED). if_fun_get_arity_and_address(ArityReg, AddressReg, FunP, BadFunLab, Pred) -> %% EmuAddressPtrReg = hipe_rtl:mk_new_reg(), @@ -801,15 +847,15 @@ if_fun_get_arity_and_address(ArityReg, AddressReg, FunP, BadFunLab, Pred) -> TrueLab0 = hipe_rtl:mk_new_label(), %% TrueLab1 = hipe_rtl:mk_new_label(), IsFunCode = test_closure(FunP, hipe_rtl:label_name(TrueLab0), BadFunLab, Pred), + {Base, Offset, Untag} = untag_ptr(FunP, ?TAG_PRIMARY_BOXED), GetArityCode = [TrueLab0, %% Funp->arity contains the arity - hipe_rtl:mk_load(ArityReg, FunP, - hipe_rtl:mk_imm(-(?TAG_PRIMARY_BOXED)+ - ?EFT_ARITY)), - hipe_rtl:mk_load(FEPtrReg, FunP, - hipe_rtl:mk_imm(-(?TAG_PRIMARY_BOXED)+ - ?EFT_FE)), + Untag, + hipe_rtl:mk_load(ArityReg, Base, + hipe_rtl:mk_imm(Offset+?EFT_ARITY)), + hipe_rtl:mk_load(FEPtrReg, Base, + hipe_rtl:mk_imm(Offset+?EFT_FE)), hipe_rtl:mk_load(AddressReg, FEPtrReg, hipe_rtl:mk_imm(?EFE_NATIVE_ADDRESS))], IsFunCode ++ GetArityCode. @@ -927,20 +973,24 @@ test_subbinary(Binary, TrueLblName, FalseLblName) -> unsafe_load_float(DstLo, DstHi, Src) -> WordSize = hipe_rtl_arch:word_size(), - Offset1 = -(?TAG_PRIMARY_BOXED) + WordSize, + {Base, Offset0, Untag} = untag_ptr(Src, ?TAG_PRIMARY_BOXED), + Offset1 = Offset0 + WordSize, Offset2 = Offset1 + 4, %% This should really be 4 and not WordSize case hipe_rtl_arch:endianess() of little -> - [hipe_rtl:mk_load(DstLo, Src, hipe_rtl:mk_imm(Offset1), int32, unsigned), - hipe_rtl:mk_load(DstHi, Src, hipe_rtl:mk_imm(Offset2), int32, unsigned)]; + [Untag, + hipe_rtl:mk_load(DstLo, Base, hipe_rtl:mk_imm(Offset1), int32, unsigned), + hipe_rtl:mk_load(DstHi, Base, hipe_rtl:mk_imm(Offset2), int32, unsigned)]; big -> - [hipe_rtl:mk_load(DstHi, Src, hipe_rtl:mk_imm(Offset1), int32, unsigned), - hipe_rtl:mk_load(DstLo, Src, hipe_rtl:mk_imm(Offset2), int32, unsigned)] + [Untag, + hipe_rtl:mk_load(DstHi, Base, hipe_rtl:mk_imm(Offset1), int32, unsigned), + hipe_rtl:mk_load(DstLo, Base, hipe_rtl:mk_imm(Offset2), int32, unsigned)] end. unsafe_untag_float(Dst, Src) -> - Offset = -(?TAG_PRIMARY_BOXED) + hipe_rtl_arch:word_size(), - [hipe_rtl:mk_fload(Dst, Src, hipe_rtl:mk_imm(Offset))]. + {Base, Offset0, Untag} = untag_ptr(Src, ?TAG_PRIMARY_BOXED), + Offset = Offset0 + hipe_rtl_arch:word_size(), + [Untag, hipe_rtl:mk_fload(Dst, Base, hipe_rtl:mk_imm(Offset))]. unsafe_tag_float(Dst, Src) -> {GetHPInsn, HP, PutHPInsn} = hipe_rtl_arch:heap_pointer(), @@ -999,8 +1049,9 @@ get_one_word_pos_bignum(USize, Size, Fail) -> unsafe_get_one_word_pos_bignum(USize, Size) -> WordSize = hipe_rtl_arch:word_size(), - Imm = hipe_rtl:mk_imm(1*WordSize-?TAG_PRIMARY_BOXED), - [hipe_rtl:mk_load(USize, Size, Imm)]. + {Base, Offset, Untag} = untag_ptr(Size, ?TAG_PRIMARY_BOXED), + Imm = hipe_rtl:mk_imm(1*WordSize+Offset), + [Untag, hipe_rtl:mk_load(USize, Base, Imm)]. -spec bignum_sizeneed(non_neg_integer()) -> non_neg_integer(). @@ -1040,7 +1091,7 @@ create_matchstate(Max, BinSize, Base, Offset, Orig, Ms) -> SizeInWords = ((ByteSize div WordSize) - 1), Header = hipe_rtl:mk_imm(mk_header(SizeInWords, ?TAG_HEADER_BIN_MATCHSTATE)), [GetHPInsn, - hipe_rtl:mk_alu(Ms, HP, add, hipe_rtl:mk_imm(?TAG_PRIMARY_BOXED)), + tag_boxed(Ms, HP), set_field_from_term({matchstate,thing_word}, Ms, Header), set_field_from_term({matchstate,{matchbuffer,orig}}, Ms, Orig), set_field_from_term({matchstate,{matchbuffer,base}}, Ms, Base), @@ -1078,7 +1129,10 @@ convert_matchstate(Ms) -> size_from_header(SizeInWords, Header), hipe_rtl:mk_alu(Hole, SizeInWords, sub, hipe_rtl:mk_imm(?SUB_BIN_WORDSIZE)), mk_var_header(BigIntHeader, Hole, ?TAG_HEADER_POS_BIG), - hipe_rtl:mk_store(Ms, hipe_rtl:mk_imm(?SUB_BIN_WORDSIZE*WordSize-?TAG_PRIMARY_BOXED), + %% Matchstates can't be literals; so untagging with ?TAG_PRIMARY_BOXED is + %% fine here + hipe_rtl:mk_store(Ms, hipe_rtl:mk_imm(?SUB_BIN_WORDSIZE*WordSize + -?TAG_PRIMARY_BOXED), BigIntHeader)]. compare_matchstate(Max, Ms, LargeEnough, TooSmall) -> @@ -1087,8 +1141,10 @@ compare_matchstate(Max, Ms, LargeEnough, TooSmall) -> SizeInWords = ((ByteSize div WordSize) - 1), Header = hipe_rtl:mk_imm(mk_header(SizeInWords, ?TAG_HEADER_BIN_MATCHSTATE)), RealHeader = hipe_rtl:mk_new_reg_gcsafe(), - [hipe_rtl:mk_load(RealHeader, Ms, hipe_rtl:mk_imm(-?TAG_PRIMARY_BOXED)), - hipe_rtl:mk_branch(RealHeader, ge, Header, LargeEnough, TooSmall)]. + %% Matchstates can't be literals; so untagging with ?TAG_PRIMARY_BOXED is fine + %% here + [hipe_rtl:mk_load(RealHeader, Ms, hipe_rtl:mk_imm(-?TAG_PRIMARY_BOXED)), + hipe_rtl:mk_branch(RealHeader, ge, Header, LargeEnough, TooSmall)]. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% @@ -1207,15 +1263,22 @@ get_field_size1({matchbuffer, base}) -> get_field_size1({matchbuffer, binsize}) -> ?MB_SIZE_SIZE. +get_field_addr_from_term(Struct, Term, Dst) -> + {Base, Offset0, Untag} = untag_ptr(Term, ?TAG_PRIMARY_BOXED), + Offset = hipe_rtl:mk_imm(get_field_offset(Struct) + Offset0), + [Untag, hipe_rtl:mk_alu(Dst, Base, add, Offset)]. + get_field_from_term(Struct, Term, Dst) -> - Offset = hipe_rtl:mk_imm(get_field_offset(Struct) - ?TAG_PRIMARY_BOXED), + {Base, Offset0, Untag} = untag_ptr(Term, ?TAG_PRIMARY_BOXED), + Offset = hipe_rtl:mk_imm(get_field_offset(Struct) + Offset0), Size = get_field_size(Struct), - hipe_rtl:mk_load(Dst, Term, Offset, Size, unsigned). + [Untag, hipe_rtl:mk_load(Dst, Base, Offset, Size, unsigned)]. set_field_from_term(Struct, Term, Value) -> - Offset = hipe_rtl:mk_imm(get_field_offset(Struct) - ?TAG_PRIMARY_BOXED), + {Base, Offset0, Untag} = untag_ptr(Term, ?TAG_PRIMARY_BOXED), + Offset = hipe_rtl:mk_imm(get_field_offset(Struct) + Offset0), Size = get_field_size(Struct), - hipe_rtl:mk_store(Term, Offset, Value, Size). + [Untag, hipe_rtl:mk_store(Base, Offset, Value, Size)]. get_field_from_pointer(Struct, Term, Dst) -> Offset = hipe_rtl:mk_imm(get_field_offset(Struct)), @@ -1229,6 +1292,8 @@ set_field_from_pointer(Struct, Term, Value) -> extract_matchbuffer(Mb, Ms) -> What = {matchstate, matchbuffer}, + %% Matchstates can't be literals; so untagging with ?TAG_PRIMARY_BOXED is fine + %% here Offset = hipe_rtl:mk_imm(get_field_offset(What) - ?TAG_PRIMARY_BOXED), hipe_rtl:mk_alu(Mb, Ms, add, Offset). diff --git a/lib/hipe/ssa/hipe_ssa.inc b/lib/hipe/ssa/hipe_ssa.inc index c7c1a8e1d7..29e8b92266 100644 --- a/lib/hipe/ssa/hipe_ssa.inc +++ b/lib/hipe/ssa/hipe_ssa.inc @@ -463,20 +463,20 @@ updateStatementDefs([], Statement, Current, Acc) -> %%---------------------------------------------------------------------- updateIndices(Current, Variable) -> - case ?CODE:is_var(Variable) of - true -> - NewVar = ?CODE:mk_new_var(), - {NewVar,gb_trees:enter(Variable, NewVar, Current)}; - false -> - case is_fp_temp(Variable) of - true -> - NewFVar = mk_new_fp_temp(), - {NewFVar,gb_trees:enter(Variable, NewFVar, Current)}; - false -> - NewReg = ?CODE:mk_new_reg(), - {NewReg,gb_trees:enter(Variable, NewReg, Current)} - end - end. + New = + case ?CODE:is_var(Variable) of + true -> ?CODE:mk_new_var(); + false -> + case is_fp_temp(Variable) of + true -> mk_new_fp_temp(); + false -> + case ?CODE:reg_is_gcsafe(Variable) of + true -> ?CODE:mk_new_reg_gcsafe(); + false -> ?CODE:mk_new_reg() + end + end + end, + {New, gb_trees:enter(Variable, New, Current)}. %%---------------------------------------------------------------------- %% Procedure : updateSuccPhi/4 diff --git a/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl b/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl index d71b924d22..ba9c03d4ba 100644 --- a/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl +++ b/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl @@ -24,6 +24,7 @@ test() -> ok = test_bad_fun_call(), ok = test_guard_bif(), ok = test_eclectic(), + ok = test_raise(), ok. %%-------------------------------------------------------------------- @@ -579,3 +580,99 @@ my_add(A, B) -> my_abs(X) -> abs(X). + +test_raise() -> + test_raise(fun() -> exit({exit,tuple}) end), + test_raise(fun() -> abs(id(x)) end), + test_raise(fun() -> throw({was,thrown}) end), + + badarg = bad_raise(fun() -> abs(id(x)) end), + + ok. + +bad_raise(Expr) -> + try + Expr() + catch + _:E:Stk -> + erlang:raise(bad_class, E, Stk) + end. + +test_raise(Expr) -> + test_raise_1(Expr), + test_raise_2(Expr), + test_raise_3(Expr). + +test_raise_1(Expr) -> + erase(exception), + try + do_test_raise_1(Expr) + catch + C:E:Stk -> + {C,E,Stk} = erase(exception) + end. + +do_test_raise_1(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here the stacktrace must be built. + put(exception, {C,E,Stk}), + erlang:raise(C, E, Stk) + end. + +test_raise_2(Expr) -> + erase(exception), + try + do_test_raise_2(Expr) + catch + C:E:Stk -> + {C,E} = erase(exception), + try + Expr() + catch + _:_:S -> + [StkTop|_] = S, + [StkTop|_] = Stk + end + end. + +do_test_raise_2(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here it is possible to replace erlang:raise/3 with + %% the raw_raise/3 instruction since the stacktrace is + %% not actually used. + put(exception, {C,E}), + erlang:raise(C, E, Stk) + end. + +test_raise_3(Expr) -> + try + do_test_raise_3(Expr) + catch + exit:{exception,C,E}:Stk -> + try + Expr() + catch + C:E:S -> + [StkTop|_] = S, + [StkTop|_] = Stk + end + end. + +do_test_raise_3(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here it is possible to replace erlang:raise/3 with + %% the raw_raise/3 instruction since the stacktrace is + %% not actually used. + erlang:raise(exit, {exception,C,E}, Stk) + end. + +id(I) -> I. diff --git a/lib/hipe/test/basic_SUITE_data/basic_receive.erl b/lib/hipe/test/basic_SUITE_data/basic_receive.erl index 5f865d7b7a..20e3f350e8 100644 --- a/lib/hipe/test/basic_SUITE_data/basic_receive.erl +++ b/lib/hipe/test/basic_SUITE_data/basic_receive.erl @@ -12,6 +12,7 @@ test() -> ok = test_wait_timeout(), ok = test_double_timeout(), ok = test_reschedule(), + ok = test_recv_mark(), ok. %%-------------------------------------------------------------------- @@ -54,3 +55,91 @@ doit(First) -> erts_debug:set_internal_state(hipe_test_reschedule_suspend, 1). %%-------------------------------------------------------------------- +%% Check that we cannot cause a recv_mark,recv_set pair to misbehave and +%% deadlock the process. + +test_recv_mark() -> + ok = test_recv_mark(fun disturber_nop/0), + ok = test_recv_mark(fun disturber_receive/0), + ok = test_recv_mark(fun disturber_other/0), + ok = test_recv_mark(fun disturber_recurse/0), + ok = test_recv_mark_after(self(), fun disturber_after_recurse/0, false), + ok = test_recv_mark(fun disturber_other_recurse/0), + ok = test_recv_mark(fun disturber_other_after/0), + ok = test_recv_mark_nested(). + +test_recv_mark(Disturber) -> + Ref = make_ref(), + self() ! Ref, + Disturber(), + receive Ref -> ok + after 0 -> error(failure) + end. + +disturber_nop() -> ok. + +disturber_receive() -> + self() ! message, + receive message -> ok end. + +disturber_other() -> + Ref = make_ref(), + self() ! Ref, + receive Ref -> ok end. + +disturber_recurse() -> + aborted = (catch test_recv_mark(fun() -> throw(aborted) end)), + ok. + +test_recv_mark_after(Recipient, Disturber, IsInner) -> + Ref = make_ref(), + Recipient ! Ref, + Disturber(), + receive + Ref -> ok + after 0 -> + case IsInner of + true -> expected; + false -> error(failure) + end + end. + +disturber_after_recurse() -> + NoOp = fun() -> ok end, + BlackHole = spawn(NoOp), + expected = test_recv_mark_after(BlackHole, NoOp, true), + ok. + +disturber_other_recurse() -> + aborted = (catch disturber_other_recurse(fun() -> throw(aborted) end)), + ok. + +disturber_other_recurse(InnerD) -> + Ref = make_ref(), + self() ! Ref, + InnerD(), + receive Ref -> ok + after 0 -> error(failure) + end. + +disturber_other_after() -> + BlackHole = spawn(fun() -> ok end), + Ref = make_ref(), + BlackHole ! Ref, + receive Ref -> error(imposible) + after 0 -> ok + end. + +test_recv_mark_nested() -> + Ref1 = make_ref(), + self() ! Ref1, + begin + Ref2 = make_ref(), + self() ! Ref2, + receive Ref2 -> ok end + end, + receive Ref1 -> ok + after 0 -> error(failure) + end. + +%%-------------------------------------------------------------------- diff --git a/lib/hipe/test/bs_SUITE_data/bs_construct.erl b/lib/hipe/test/bs_SUITE_data/bs_construct.erl index b9e7d93570..aa85626857 100644 --- a/lib/hipe/test/bs_SUITE_data/bs_construct.erl +++ b/lib/hipe/test/bs_SUITE_data/bs_construct.erl @@ -279,13 +279,22 @@ bad_floats() -> %% (incorrectly) signed. huge_binaries() -> - AlmostIllegal = id(<<0:(id((1 bsl 32)-8))>>), case erlang:system_info(wordsize) of - 4 -> huge_binaries_32(AlmostIllegal); + 4 -> + Old = erts_debug:set_internal_state(available_internal_state, true), + case erts_debug:set_internal_state(binary, (1 bsl 29)-1) of + false -> + io:format("\nNot enough memory to create 512Mb binary\n",[]); + Bin-> + huge_binaries_32(Bin) + end, + erts_debug:set_internal_state(available_internal_state, Old); + 8 -> ok end, garbage_collect(), id(<<0:(id((1 bsl 31)-1))>>), + garbage_collect(), id(<<0:(id((1 bsl 30)-1))>>), garbage_collect(), ok. diff --git a/lib/hipe/test/hipe_testsuite_driver.erl b/lib/hipe/test/hipe_testsuite_driver.erl index ee9c57a908..8813af5dfc 100644 --- a/lib/hipe/test/hipe_testsuite_driver.erl +++ b/lib/hipe/test/hipe_testsuite_driver.erl @@ -161,7 +161,8 @@ run(TestCase, Dir, _OutDir) -> %% end, DataFiles), %% try ok = TestCase:test(), - HiPEOpts = try TestCase:hipe_options() catch error:undef -> [] end, + HiPEOpts0 = try TestCase:hipe_options() catch error:undef -> [] end, + HiPEOpts = HiPEOpts0 ++ hipe_options(), {ok, TestCase} = hipe:c(TestCase, HiPEOpts), ok = TestCase:test(), {ok, TestCase} = hipe:c(TestCase, [o1|HiPEOpts]), @@ -179,3 +180,6 @@ run(TestCase, Dir, _OutDir) -> %% lists:foreach(fun (DF) -> ok end, % = file:delete(DF) end, %% [filename:join(OutDir, D) || D <- DataFiles]) %% end. + +hipe_options() -> + [verify_gcsafe]. diff --git a/lib/hipe/vsn.mk b/lib/hipe/vsn.mk index f88d9147b1..508ec00548 100644 --- a/lib/hipe/vsn.mk +++ b/lib/hipe/vsn.mk @@ -1 +1 @@ -HIPE_VSN = 3.16.1 +HIPE_VSN = 3.17 diff --git a/lib/hipe/x86/hipe_rtl_to_x86.erl b/lib/hipe/x86/hipe_rtl_to_x86.erl index 31e4f6e4ac..22947da148 100644 --- a/lib/hipe/x86/hipe_rtl_to_x86.erl +++ b/lib/hipe/x86/hipe_rtl_to_x86.erl @@ -646,7 +646,7 @@ conv_imm(Opnd, Map) -> is_imm64(Value) when is_integer(Value) -> (Value < -(1 bsl (32 - 1))) or (Value > (1 bsl (32 - 1)) - 1); is_imm64({_,atom}) -> false; % Atoms are 32 bits. -is_imm64({_,c_const}) -> false; % c_consts are 32 bits. +is_imm64({_,c_const}) -> true; % c_consts are 64 bits. is_imm64({_,_}) -> true . % Other relocs are 64 bits. -else. conv_imm(Opnd, Map) -> @@ -777,6 +777,18 @@ conv_fconv(Dst, Src) -> %%% Finalise the conversion of a 2-address FP operation. +-ifdef(HIPE_AMD64). +conv_fp_unary(Dst, Src, 'fchs') -> + Tmp = new_untagged_temp(), + case same_opnd(Dst, Src) of + true -> + []; + _ -> + [hipe_x86:mk_fmove(Src, Dst)] + end ++ + mk_load_address(c_const, hipe_x86:mk_imm({sse2_fnegate_mask, c_const}), Tmp) ++ + [hipe_x86:mk_fp_binop('xorpd', hipe_x86:mk_mem(Tmp, hipe_x86:mk_imm(0), double), Dst)]. +-else. conv_fp_unary(Dst, Src, FpUnOp) -> case same_opnd(Dst, Src) of true -> @@ -785,6 +797,7 @@ conv_fp_unary(Dst, Src, FpUnOp) -> [hipe_x86:mk_fmove(Src, Dst), hipe_x86:mk_fp_unop(FpUnOp, Dst)] end. +-endif. conv_fp_unop(RtlFpUnOp) -> case RtlFpUnOp of @@ -854,13 +867,8 @@ mk_jmp_switch(Index, JTabLab, Labels) -> %%% Finalise the translation of a load_address instruction. -ifdef(HIPE_AMD64). -mk_load_address(Type, Src, Dst) -> - case Type of - c_const -> % 32 bits - [hipe_x86:mk_move(Src, Dst)]; - _ -> - [hipe_x86:mk_move64(Src, Dst)] - end. +mk_load_address(_Type, Src, Dst) -> + [hipe_x86:mk_move64(Src, Dst)]. -else. mk_load_address(_Type, Src, Dst) -> [hipe_x86:mk_move(Src, Dst)]. diff --git a/lib/hipe/x86/hipe_x86_assemble.erl b/lib/hipe/x86/hipe_x86_assemble.erl index 50919bdf4e..9d2586a14d 100644 --- a/lib/hipe/x86/hipe_x86_assemble.erl +++ b/lib/hipe/x86/hipe_x86_assemble.erl @@ -735,6 +735,7 @@ resolve_sse2_op(Op) -> fdiv -> divsd; fmul -> mulsd; fsub -> subsd; + xorpd -> xorpd; _ -> exit({?MODULE, unknown_sse2_operator, Op}) end. diff --git a/lib/ic/doc/src/notes.xml b/lib/ic/doc/src/notes.xml index ea8bf758cf..fc68ec386c 100644 --- a/lib/ic/doc/src/notes.xml +++ b/lib/ic/doc/src/notes.xml @@ -31,7 +31,22 @@ <file>notes.xml</file> </header> - <section><title>IC 4.4.2</title> + <section><title>IC 4.4.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + +<section><title>IC 4.4.2</title> <section><title>Fixed Bugs and Malfunctions</title> <list> diff --git a/lib/ic/test/c_client_erl_server_SUITE_data/c_client.c b/lib/ic/test/c_client_erl_server_SUITE_data/c_client.c index b3a18e03d4..446b46ad82 100644 --- a/lib/ic/test/c_client_erl_server_SUITE_data/c_client.c +++ b/lib/ic/test/c_client_erl_server_SUITE_data/c_client.c @@ -1365,8 +1365,8 @@ static int cmp_strRec(m_strRec *b1, m_strRec *b2) return 0; if (!cmp_str(b1->str6,b2->str6)) return 0; - for (i = 0; i < 2; i++) - for (j = 0; j < 3; j++) + for (i = 0; i < 3; i++) + for (j = 0; j < 2; j++) if (b1->str7[i][j] != b2->str7[i][j]) return 0; for (j = 0; j < 3; j++) @@ -1579,8 +1579,8 @@ static void print_strRec(m_strRec* sr) fprintf(stdout, "\nboolean bb : %d\n",sr->bb); fprintf(stdout, "string str4 : %s\n",sr->str4); fprintf(stdout, "str7[2][3] :\n"); - for (i = 0; i < 2; i++) - for (j = 0; j < 3; j++) + for (i = 0; i < 3; i++) + for (j = 0; j < 2; j++) fprintf(stdout, "str7[%d][%d]: %ld\n", i, j, sr->str7[i][j]); fprintf(stdout, "str5._length : %ld\n",sr->str5._length); for (j = 0; j < sr->str5._length; j++) diff --git a/lib/ic/test/c_client_erl_server_proto_SUITE_data/c_client.c b/lib/ic/test/c_client_erl_server_proto_SUITE_data/c_client.c index 40c7328f03..d6a78d2481 100644 --- a/lib/ic/test/c_client_erl_server_proto_SUITE_data/c_client.c +++ b/lib/ic/test/c_client_erl_server_proto_SUITE_data/c_client.c @@ -1369,8 +1369,8 @@ static int cmp_strRec(m_strRec *b1, m_strRec *b2) return 0; if (!cmp_str(b1->str6,b2->str6)) return 0; - for (i = 0; i < 2; i++) - for (j = 0; j < 3; j++) + for (i = 0; i < 3; i++) + for (j = 0; j < 2; j++) if (b1->str7[i][j] != b2->str7[i][j]) return 0; for (j = 0; j < 3; j++) @@ -1583,8 +1583,8 @@ static void print_strRec(m_strRec* sr) fprintf(stdout, "\nboolean bb : %d\n",sr->bb); fprintf(stdout, "string str4 : %s\n",sr->str4); fprintf(stdout, "str7[2][3] :\n"); - for (i = 0; i < 2; i++) - for (j = 0; j < 3; j++) + for (i = 0; i < 3; i++) + for (j = 0; j < 2; j++) fprintf(stdout, "str7[%d][%d]: %ld\n", i, j, sr->str7[i][j]); fprintf(stdout, "str5._length : %ld\n",sr->str5._length); for (j = 0; j < sr->str5._length; j++) diff --git a/lib/ic/test/c_client_erl_server_proto_tmo_SUITE_data/c_client.c b/lib/ic/test/c_client_erl_server_proto_tmo_SUITE_data/c_client.c index 33cfe71322..17ef21f4f4 100644 --- a/lib/ic/test/c_client_erl_server_proto_tmo_SUITE_data/c_client.c +++ b/lib/ic/test/c_client_erl_server_proto_tmo_SUITE_data/c_client.c @@ -1369,8 +1369,8 @@ static int cmp_strRec(m_strRec *b1, m_strRec *b2) return 0; if (!cmp_str(b1->str6,b2->str6)) return 0; - for (i = 0; i < 2; i++) - for (j = 0; j < 3; j++) + for (i = 0; i < 3; i++) + for (j = 0; j < 2; j++) if (b1->str7[i][j] != b2->str7[i][j]) return 0; for (j = 0; j < 3; j++) @@ -1583,8 +1583,8 @@ static void print_strRec(m_strRec* sr) fprintf(stdout, "\nboolean bb : %d\n",sr->bb); fprintf(stdout, "string str4 : %s\n",sr->str4); fprintf(stdout, "str7[2][3] :\n"); - for (i = 0; i < 2; i++) - for (j = 0; j < 3; j++) + for (i = 0; i < 3; i++) + for (j = 0; j < 2; j++) fprintf(stdout, "str7[%d][%d]: %ld\n", i, j, sr->str7[i][j]); fprintf(stdout, "str5._length : %ld\n",sr->str5._length); for (j = 0; j < sr->str5._length; j++) diff --git a/lib/ic/vsn.mk b/lib/ic/vsn.mk index f0e5e7c266..b9f1ef7f20 100644 --- a/lib/ic/vsn.mk +++ b/lib/ic/vsn.mk @@ -1 +1 @@ -IC_VSN = 4.4.2 +IC_VSN = 4.4.3 diff --git a/lib/inets/doc/src/Makefile b/lib/inets/doc/src/Makefile index 14f12ee949..cbfa5c9e30 100644 --- a/lib/inets/doc/src/Makefile +++ b/lib/inets/doc/src/Makefile @@ -39,6 +39,7 @@ RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) XML_APPLICATION_FILES = ref_man.xml XML_CHAPTER_FILES = \ + introduction.xml \ inets_services.xml \ http_client.xml \ http_server.xml \ diff --git a/lib/inets/doc/src/httpc.xml b/lib/inets/doc/src/httpc.xml index 29e4b22632..58714328c5 100644 --- a/lib/inets/doc/src/httpc.xml +++ b/lib/inets/doc/src/httpc.xml @@ -287,8 +287,7 @@ {autoredirect, boolean()} | {proxy_auth, {userstring(), passwordstring()}} | {version, http_version()} | - {relaxed, boolean()} | - {url_encode, boolean()}</v> + {relaxed, boolean()}</v> <v>timeout() = integer() >= 0 | infinity</v> <v>Options = options()</v> <v>options() = [option()]</v> @@ -379,13 +378,6 @@ from the HTTP-standard are enabled.</p> <p>Default is <c>false</c>.</p> </item> - - <tag><c><![CDATA[url_encode]]></c></tag> - <item> - <p>Applies Percent-encoding, also known as URL encoding on the - URL.</p> - <p>Default is <c>false</c>.</p> - </item> </taglist> <p>Option (<c>option()</c>) details:</p> diff --git a/lib/inets/doc/src/notes.xml b/lib/inets/doc/src/notes.xml index 10ef84d7cf..70b2811c0e 100644 --- a/lib/inets/doc/src/notes.xml +++ b/lib/inets/doc/src/notes.xml @@ -33,7 +33,88 @@ <file>notes.xml</file> </header> - <section><title>Inets 6.4.2</title> + <section><title>Inets 6.4.5</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + CGI environment variable CONTENT_LENGTH shall be a string</p> + <p> + Own Id: OTP-14679</p> + </item> + <item> + <p> + In relaxed mode disregard Content-Length header if there + is also a Transfer-Encoding header.</p> + <p> + Own Id: OTP-14727</p> + </item> + <item> + <p> + Eliminated race condition, that could cause http request + to sporadically fail to complete successfully, when + keep-alive connections are used.</p> + <p> + Own Id: OTP-14783</p> + </item> + </list> + </section> + +</section> + +<section><title>Inets 6.4.4</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Correct the handling of location headers so that the + status code is not hard coded. This should have been + fixed by commit 2cc5ba70cbbc6b3ace81a2a0324417c3b65265bb + but unfortunately was broken during a code refactoring + and unnoticed due to a faulty placed test case.</p> + <p> + Own Id: OTP-14761</p> + </item> + </list> + </section> + +</section> + +<section><title>Inets 6.4.3</title> + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + Fix broken handling of POST requests</p> + <p> + New chunk mechanism of body data in POST requests added + in 5d01c70ca399edf28e99dc760506329689fab6ba broke + handling of POST body data not using the new mechanism.</p> + <p> + Own Id: OTP-14656</p> + </item> + <item> + <p> + Make sure ints:stop/2 of the service httpd is synchronous</p> + <p> + Own Id: OTP-14696</p> + </item> + <item> + <p> + Honor status code returned by ESI script and modernize + "location" header handling.</p> + <p> + Own Id: OTP-14716</p> + </item> + </list> + </section> + +</section> + +<section><title>Inets 6.4.2</title> <section><title>Fixed Bugs and Malfunctions</title> <list> diff --git a/lib/inets/src/http_client/httpc.erl b/lib/inets/src/http_client/httpc.erl index bf2da82603..821eb7f02f 100644 --- a/lib/inets/src/http_client/httpc.erl +++ b/lib/inets/src/http_client/httpc.erl @@ -175,10 +175,10 @@ request(Method, (Method =:= delete) orelse (Method =:= trace) andalso (is_atom(Profile) orelse is_pid(Profile)) -> - case uri_parse(Url, Options) of - {error, Reason} -> + case uri_string:parse(uri_string:normalize(Url)) of + {error, Reason, _} -> {error, Reason}; - {ok, ParsedUrl} -> + ParsedUrl -> case header_parse(Headers) of {error, Reason} -> {error, Reason}; @@ -189,10 +189,10 @@ request(Method, end. do_request(Method, {Url, Headers, ContentType, Body}, HTTPOptions, Options, Profile) -> - case uri_parse(Url, Options) of - {error, Reason} -> + case uri_string:parse(uri_string:normalize(Url)) of + {error, Reason, _} -> {error, Reason}; - {ok, ParsedUrl} -> + ParsedUrl -> handle_request(Method, Url, ParsedUrl, Headers, ContentType, Body, HTTPOptions, Options, Profile) @@ -312,23 +312,28 @@ store_cookies(SetCookieHeaders, Url) -> store_cookies(SetCookieHeaders, Url, Profile) when is_atom(Profile) orelse is_pid(Profile) -> - try - begin + case uri_string:parse(uri_string:normalize(Url)) of + {error, Bad, _} -> + {error, {parse_failed, Bad}}; + URI -> + Scheme = scheme_to_atom(maps:get(scheme, URI, '')), + Host = maps:get(host, URI, ""), + Port = maps:get(port, URI, default_port(Scheme)), + Path = uri_string:recompose(#{path => maps:get(path, URI, "")}), %% Since the Address part is not actually used %% by the manager when storing cookies, we dont %% care about ipv6-host-with-brackets. - {ok, {_, _, Host, Port, Path, _}} = uri_parse(Url), Address = {Host, Port}, ProfileName = profile_name(Profile), Cookies = httpc_cookie:cookies(SetCookieHeaders, Path, Host), httpc_manager:store_cookies(Cookies, Address, ProfileName), ok - end - catch - error:{badmatch, Bad} -> - {error, {parse_failed, Bad}} end. +default_port(http) -> + 80; +default_port(https) -> + 443. %%-------------------------------------------------------------------------- %% cookie_header(Url) -> Header | {error, Reason} @@ -495,7 +500,7 @@ service_info(Pid) -> %%% Internal functions %%%======================================================================== handle_request(Method, Url, - {Scheme, UserInfo, Host, Port, Path, Query}, + URI, Headers0, ContentType, Body0, HTTPOptions0, Options0, Profile) -> @@ -520,37 +525,40 @@ handle_request(Method, Url, throw({error, {bad_body, Body0}}) end, - HTTPOptions = http_options(HTTPOptions0), - Options = request_options(Options0), - Sync = proplists:get_value(sync, Options), - Stream = proplists:get_value(stream, Options), - Host2 = http_request:normalize_host(Scheme, Host, Port), - HeadersRecord = header_record(NewHeaders, Host2, HTTPOptions), - Receiver = proplists:get_value(receiver, Options), - SocketOpts = proplists:get_value(socket_opts, Options), - BracketedHost = proplists:get_value(ipv6_host_with_brackets, - Options), - MaybeEscPath = maybe_encode_uri(HTTPOptions, Path), - MaybeEscQuery = maybe_encode_uri(HTTPOptions, Query), - AbsUri = maybe_encode_uri(HTTPOptions, Url), + HTTPOptions = http_options(HTTPOptions0), + Options = request_options(Options0), + Sync = proplists:get_value(sync, Options), + Stream = proplists:get_value(stream, Options), + Receiver = proplists:get_value(receiver, Options), + SocketOpts = proplists:get_value(socket_opts, Options), + BracketedHost = proplists:get_value(ipv6_host_with_brackets, + Options), + + Scheme = scheme_to_atom(maps:get(scheme, URI, '')), + Userinfo = maps:get(userinfo, URI, ""), + Host = http_util:maybe_add_brackets(maps:get(host, URI, ""), BracketedHost), + Port = maps:get(port, URI, default_port(Scheme)), + Host2 = http_request:normalize_host(Scheme, Host, Port), + Path = uri_string:recompose(#{path => maps:get(path, URI, "")}), + Query = add_question_mark(maps:get(query, URI, "")), + HeadersRecord = header_record(NewHeaders, Host2, HTTPOptions), Request = #request{from = Receiver, - scheme = Scheme, - address = {host_address(Host, BracketedHost), Port}, - path = MaybeEscPath, - pquery = MaybeEscQuery, + scheme = Scheme, + address = {Host, Port}, + path = Path, + pquery = Query, method = Method, headers = HeadersRecord, content = {ContentType, Body}, settings = HTTPOptions, - abs_uri = AbsUri, - userinfo = UserInfo, + abs_uri = Url, + userinfo = Userinfo, stream = Stream, headers_as_is = headers_as_is(Headers0, Options), socket_opts = SocketOpts, started = Started, ipv6_host_with_brackets = BracketedHost}, - case httpc_manager:request(Request, profile_name(Profile)) of {ok, RequestId} -> handle_answer(RequestId, Sync, Options); @@ -565,14 +573,31 @@ handle_request(Method, Url, Error end. + +add_question_mark(<<>>) -> + <<>>; +add_question_mark([]) -> + []; +add_question_mark(Comp) when is_binary(Comp) -> + <<$?, Comp/binary>>; +add_question_mark(Comp) when is_list(Comp) -> + [$?|Comp]. + + +scheme_to_atom("http") -> + http; +scheme_to_atom("https") -> + https; +scheme_to_atom('') -> + ''; +scheme_to_atom(Scheme) -> + throw({error, {bad_scheme, Scheme}}). + + ensure_chunked_encoding(Hdrs) -> Key = "transfer-encoding", lists:keystore(Key, 1, Hdrs, {Key, "chunked"}). -maybe_encode_uri(#http_options{url_encode = true}, URI) -> - http_uri:encode(URI); -maybe_encode_uri(_, URI) -> - URI. mk_chunkify_fun(ProcessBody) -> fun(eof_body) -> @@ -1190,17 +1215,6 @@ validate_headers(RequestHeaders, _, _) -> %% These functions is just simple wrappers to parse specifically HTTP URIs %%-------------------------------------------------------------------------- -scheme_defaults() -> - [{http, 80}, {https, 443}]. - -uri_parse(URI) -> - http_uri:parse(URI, [{scheme_defaults, scheme_defaults()}]). - -uri_parse(URI, Opts) -> - http_uri:parse(URI, [{scheme_defaults, scheme_defaults()} | Opts]). - - -%%-------------------------------------------------------------------------- header_parse([]) -> ok; header_parse([{Field, Value}|T]) when is_list(Field), is_list(Value) -> @@ -1221,10 +1235,6 @@ child_name(Pid, [{Name, Pid} | _]) -> child_name(Pid, [_ | Children]) -> child_name(Pid, Children). -host_address(Host, false) -> - Host; -host_address(Host, true) -> - string:strip(string:strip(Host, right, $]), left, $[). check_body_gen({Fun, _}) when is_function(Fun) -> ok; diff --git a/lib/inets/src/http_client/httpc_handler.erl b/lib/inets/src/http_client/httpc_handler.erl index bd1d2e833a..1482f4f922 100644 --- a/lib/inets/src/http_client/httpc_handler.erl +++ b/lib/inets/src/http_client/httpc_handler.erl @@ -109,7 +109,7 @@ start_link(Parent, Request, Options, ProfileName) -> %% to be called by the httpc manager process. %%-------------------------------------------------------------------- send(Request, Pid) -> - call(Request, Pid, 5000). + call(Request, Pid). %%-------------------------------------------------------------------- @@ -712,12 +712,16 @@ do_handle_info({'EXIT', _, _}, State = #state{request = undefined}) -> do_handle_info({'EXIT', _, _}, State) -> {noreply, State#state{status = close}}. - call(Msg, Pid) -> - call(Msg, Pid, infinity). - -call(Msg, Pid, Timeout) -> - gen_server:call(Pid, Msg, Timeout). + try gen_server:call(Pid, Msg) + catch + exit:{noproc, _} -> + {error, closed}; + exit:{normal, _} -> + {error, closed}; + exit:{{shutdown, _},_} -> + {error, closed} + end. cast(Msg, Pid) -> gen_server:cast(Pid, Msg). @@ -736,7 +740,7 @@ maybe_send_answer(Request, Answer, State) -> answer_request(Request, Answer, State). deliver_answer(#request{from = From} = Request) - when is_pid(From) -> + when From =/= answer_sent -> Response = httpc_response:error(Request, socket_closed_remotely), httpc_response:send(From, Response); deliver_answer(_Request) -> diff --git a/lib/inets/src/http_client/httpc_manager.erl b/lib/inets/src/http_client/httpc_manager.erl index a63864493f..ffdf1603b3 100644 --- a/lib/inets/src/http_client/httpc_manager.erl +++ b/lib/inets/src/http_client/httpc_manager.erl @@ -849,11 +849,11 @@ pipeline_or_keep_alive(#request{id = Id, from = From} = Request, HandlerPid, #state{handler_db = HandlerDb} = State) -> - case (catch httpc_handler:send(Request, HandlerPid)) of + case httpc_handler:send(Request, HandlerPid) of ok -> HandlerInfo = {Id, HandlerPid, From}, ets:insert(HandlerDb, HandlerInfo); - _ -> % timeout pipelining failed + {error, closed} -> % timeout pipelining failed start_handler(Request, State) end. diff --git a/lib/inets/src/http_client/httpc_response.erl b/lib/inets/src/http_client/httpc_response.erl index b3b11b74ab..58ab9144df 100644 --- a/lib/inets/src/http_client/httpc_response.erl +++ b/lib/inets/src/http_client/httpc_response.erl @@ -190,7 +190,7 @@ parse_status_code(<<?CR, ?LF, Rest/binary>>, StatusCodeStr, MaxHeaderSize, Result, true) -> parse_headers(Rest, [], [], MaxHeaderSize, [" ", list_to_integer(lists:reverse( - string:strip(StatusCodeStr))) + string:trim(StatusCodeStr))) | Result], true); parse_status_code(<<?SP, Rest/binary>>, StatusCodeStr, @@ -269,7 +269,7 @@ parse_headers(<<?LF,?LF,Body/binary>>, Header, Headers, MaxHeaderSize, Result, Relaxed); parse_headers(<<?CR,?LF,?CR,?LF,Body/binary>>, Header, Headers, - MaxHeaderSize, Result, _) -> + MaxHeaderSize, Result, Relaxed) -> HTTPHeaders = [lists:reverse(Header) | Headers], Length = lists:foldl(fun(H, Acc) -> length(H) + Acc end, 0, HTTPHeaders), @@ -277,8 +277,42 @@ parse_headers(<<?CR,?LF,?CR,?LF,Body/binary>>, Header, Headers, true -> ResponseHeaderRcord = http_response:headers(HTTPHeaders, #http_response_h{}), - {ok, list_to_tuple( - lists:reverse([Body, ResponseHeaderRcord | Result]))}; + + %% RFC7230, Section 3.3.3 + %% If a message is received with both a Transfer-Encoding and a + %% Content-Length header field, the Transfer-Encoding overrides the + %% Content-Length. Such a message might indicate an attempt to + %% perform request smuggling (Section 9.5) or response splitting + %% (Section 9.4) and ought to be handled as an error. A sender MUST + %% remove the received Content-Length field prior to forwarding such + %% a message downstream. + case ResponseHeaderRcord#http_response_h.'transfer-encoding' of + undefined -> + {ok, list_to_tuple( + lists:reverse([Body, ResponseHeaderRcord | Result]))}; + Value -> + TransferEncoding = string:lowercase(Value), + ContentLength = ResponseHeaderRcord#http_response_h.'content-length', + if + %% Respond without error but remove Content-Length field in relaxed mode + (Relaxed =:= true) + andalso (TransferEncoding =:= "chunked") + andalso (ContentLength =/= "-1") -> + ResponseHeaderRcordFixed = + ResponseHeaderRcord#http_response_h{'content-length' = "-1"}, + {ok, list_to_tuple( + lists:reverse([Body, ResponseHeaderRcordFixed | Result]))}; + %% Respond with error in default (not relaxed) mode + (Relaxed =:= false) + andalso (TransferEncoding =:= "chunked") + andalso (ContentLength =/= "-1") -> + throw({error, {headers_conflict, {'content-length', + 'transfer-encoding'}}}); + true -> + {ok, list_to_tuple( + lists:reverse([Body, ResponseHeaderRcord | Result]))} + end + end; false -> throw({error, {header_too_long, MaxHeaderSize, MaxHeaderSize-Length}}) @@ -343,58 +377,173 @@ status_server_error_50x(Response, Request) -> {stop, {Request#request.id, Msg}}. -redirect(Response = {StatusLine, Headers, Body}, Request) -> +redirect(Response = {_, Headers, _}, Request) -> {_, Data} = format_response(Response), case Headers#http_response_h.location of - undefined -> - transparent(Response, Request); - RedirUrl -> - UrlParseOpts = [{ipv6_host_with_brackets, - Request#request.ipv6_host_with_brackets}], - case uri_parse(RedirUrl, UrlParseOpts) of - {error, no_scheme} when - (Request#request.settings)#http_options.relaxed -> - NewLocation = fix_relative_uri(Request, RedirUrl), - redirect({StatusLine, Headers#http_response_h{ - location = NewLocation}, - Body}, Request); - {error, Reason} -> - {ok, error(Request, Reason), Data}; - %% Automatic redirection - {ok, {Scheme, _, Host, Port, Path, Query}} -> - HostPort = http_request:normalize_host(Scheme, Host, Port), - NewHeaders = - (Request#request.headers)#http_request_h{host = HostPort}, - NewRequest = - Request#request{redircount = - Request#request.redircount+1, - scheme = Scheme, - headers = NewHeaders, - address = {Host,Port}, - path = Path, - pquery = Query, - abs_uri = - atom_to_list(Scheme) ++ "://" ++ - Host ++ ":" ++ - integer_to_list(Port) ++ - Path ++ Query}, - {redirect, NewRequest, Data} - end + undefined -> + transparent(Response, Request); + RedirUrl -> + Brackets = Request#request.ipv6_host_with_brackets, + case uri_string:parse(RedirUrl) of + {error, Reason, _} -> + {ok, error(Request, Reason), Data}; + %% Automatic redirection + URI -> + {Host, Port0} = Request#request.address, + Port = maybe_to_integer(Port0), + Path = Request#request.path, + Scheme = atom_to_list(Request#request.scheme), + Query = Request#request.pquery, + URIMap = resolve_uri(Scheme, Host, Port, Path, Query, URI), + TScheme = list_to_atom(maps:get(scheme, URIMap)), + THost = http_util:maybe_add_brackets(maps:get(host, URIMap), Brackets), + TPort = maps:get(port, URIMap), + TPath = maps:get(path, URIMap), + TQuery = maps:get(query, URIMap, ""), + NewURI = uri_string:normalize( + uri_string:recompose(URIMap)), + HostPort = http_request:normalize_host(TScheme, THost, TPort), + NewHeaders = + (Request#request.headers)#http_request_h{host = HostPort}, + NewRequest = + Request#request{redircount = + Request#request.redircount+1, + scheme = TScheme, + headers = NewHeaders, + address = {THost,TPort}, + path = TPath, + pquery = TQuery, + abs_uri = NewURI}, + {redirect, NewRequest, Data} + end + end. + + +%% RFC3986 - 5.2.2. Transform References +resolve_uri(Scheme, Host, Port, Path, Query, URI) -> + resolve_uri(Scheme, Host, Port, Path, Query, URI, #{}). +%% +resolve_uri(Scheme, Host, Port, Path, Query, URI, Map0) -> + case maps:is_key(scheme, URI) of + true -> + Port = get_port(URI), + maybe_add_query( + Map0#{scheme => maps:get(scheme, URI), + host => maps:get(host, URI), + port => Port, + path => maps:get(path, URI)}, + URI); + false -> + Map = Map0#{scheme => Scheme}, + resolve_authority(Host, Port, Path, Query, URI, Map) + end. + + +get_port(URI) -> + Scheme = maps:get(scheme, URI), + case maps:get(port, URI, undefined) of + undefined -> + get_default_port(Scheme); + Port -> + Port + end. + + +get_default_port("http") -> + 80; +get_default_port("https") -> + 443. + + +resolve_authority(Host, Port, Path, Query, RelURI, Map) -> + case maps:is_key(host, RelURI) of + true -> + Port = get_port(RelURI), + maybe_add_query( + Map#{host => maps:get(host, RelURI), + port => Port, + path => maps:get(path, RelURI)}, + RelURI); + false -> + Map1 = Map#{host => Host, + port => Port}, + resolve_path(Path, Query, RelURI, Map1) + end. + + +maybe_add_query(Map, RelURI) -> + case maps:is_key(query, RelURI) of + true -> + Map#{query => maps:get(query, RelURI)}; + false -> + Map + end. + + +resolve_path(Path, Query, RelURI, Map) -> + case maps:is_key(path, RelURI) of + true -> + Path1 = calculate_path(Path, maps:get(path, RelURI)), + maybe_add_query( + Map#{path => Path1}, + RelURI); + false -> + Map1 = Map#{path => Path}, + resolve_query(Query, RelURI, Map1) + end. + + +calculate_path(BaseP, RelP) -> + case starts_with_slash(RelP) of + true -> + RelP; + false -> + merge_paths(BaseP, RelP) end. -maybe_to_list(Port) when is_integer(Port) -> - integer_to_list(Port); -maybe_to_list(Port) when is_list(Port) -> + +starts_with_slash([$/|_]) -> + true; +starts_with_slash(<<$/,_/binary>>) -> + true; +starts_with_slash(_) -> + false. + + +%% RFC3986 - 5.2.3. Merge Paths +merge_paths("", RelP) -> + [$/|RelP]; +merge_paths(BaseP, RelP) when is_list(BaseP) -> + do_merge_paths(lists:reverse(BaseP), RelP); +merge_paths(BaseP, RelP) when is_binary(BaseP) -> + B = binary_to_list(BaseP), + R = binary_to_list(RelP), + Res = merge_paths(B, R), + list_to_binary(Res). + + +do_merge_paths([$/|_] = L, RelP) -> + lists:reverse(L) ++ RelP; +do_merge_paths([_|T], RelP) -> + do_merge_paths(T, RelP). + + +resolve_query(Query, RelURI, Map) -> + case maps:is_key(query, RelURI) of + true -> + Map#{query => maps:get(query, RelURI)}; + false -> + Map#{query => Query} + end. + + +maybe_to_integer(Port) when is_list(Port) -> + {Port1, _} = string:to_integer(Port), + Port1; +maybe_to_integer(Port) when is_integer(Port) -> Port. -%%% Guessing that we received a relative URI, fix it to become an absoluteURI -fix_relative_uri(Request, RedirUrl) -> - {Server, Port0} = Request#request.address, - Port = maybe_to_list(Port0), - Path = Request#request.path, - atom_to_list(Request#request.scheme) ++ "://" ++ Server ++ ":" ++ Port - ++ Path ++ RedirUrl. - + error(#request{id = Id}, Reason) -> {Id, {error, Reason}}. @@ -444,18 +593,3 @@ format_response({StatusLine, Headers, Body}) -> {Body, <<>>} end, {{StatusLine, http_response:header_list(Headers), NewBody}, Data}. - -%%-------------------------------------------------------------------------- -%% These functions is just simple wrappers to parse specifically HTTP URIs -%%-------------------------------------------------------------------------- - -scheme_defaults() -> - [{http, 80}, {https, 443}]. - -uri_parse(URI, Opts) -> - http_uri:parse(URI, [{scheme_defaults, scheme_defaults()} | Opts]). - - -%%-------------------------------------------------------------------------- - - diff --git a/lib/inets/src/http_lib/http_util.erl b/lib/inets/src/http_lib/http_util.erl index 487d04f7aa..5577b00cc8 100644 --- a/lib/inets/src/http_lib/http_util.erl +++ b/lib/inets/src/http_lib/http_util.erl @@ -27,7 +27,8 @@ convert_month/1, is_hostname/1, timestamp/0, timeout/2, - html_encode/1 + html_encode/1, + maybe_add_brackets/2 ]). @@ -194,6 +195,24 @@ html_encode(Chars) -> lists:append([char_to_html_entity(Char, Reserved) || Char <- Chars]). +maybe_add_brackets(Addr, false) -> + Addr; +maybe_add_brackets(Addr, true) when is_list(Addr) -> + case is_ipv6_address(Addr) of + true -> + [$[|Addr] ++ "]"; + false -> + Addr + end; +maybe_add_brackets(Addr, true) when is_binary(Addr) -> + case is_ipv6_address(Addr) of + true -> + <<$[,Addr/binary,$]>>; + false -> + Addr + end. + + %%%======================================================================== %%% Internal functions %%%======================================================================== @@ -205,3 +224,14 @@ char_to_html_entity(Char, Reserved) -> false -> [Char] end. + +is_ipv6_address(Addr) when is_binary(Addr) -> + B = binary_to_list(Addr), + is_ipv6_address(B); +is_ipv6_address(Addr) when is_list(Addr) -> + case inet:parse_ipv6strict_address(Addr) of + {ok, _ } -> + true; + {error, _} -> + false + end. diff --git a/lib/inets/src/http_server/httpd_esi.erl b/lib/inets/src/http_server/httpd_esi.erl index 9406b47802..f5493f6fad 100644 --- a/lib/inets/src/http_server/httpd_esi.erl +++ b/lib/inets/src/http_server/httpd_esi.erl @@ -66,7 +66,7 @@ handle_headers("") -> {ok, [], 200}; handle_headers(Headers) -> NewHeaders = string:tokens(Headers, ?CRLF), - handle_headers(NewHeaders, [], 200). + handle_headers(NewHeaders, [], 200, true). %%%======================================================================== %%% Internal functions @@ -80,21 +80,17 @@ parse_headers([?CR, ?LF, ?CR, ?LF | Rest], Acc) -> parse_headers([Char | Rest], Acc) -> parse_headers(Rest, [Char | Acc]). -handle_headers([], NewHeaders, StatusCode) -> +handle_headers([], NewHeaders, StatusCode, _) -> {ok, NewHeaders, StatusCode}; -handle_headers([Header | Headers], NewHeaders, StatusCode) -> +handle_headers([Header | Headers], NewHeaders, StatusCode, NoESIStatus) -> {FieldName, FieldValue} = httpd_response:split_header(Header, []), case FieldName of - "location" -> - case http_request:is_absolut_uri(FieldValue) of - true -> - handle_headers(Headers, - [{FieldName, FieldValue} | NewHeaders], - 302); - false -> - {proceed, FieldValue} - end; + "location" when NoESIStatus == true -> + handle_headers(Headers, + [{FieldName, FieldValue} | NewHeaders], + 302, NoESIStatus); + "status" -> NewStatusCode = case httpd_util:split(FieldValue," ",2) of @@ -103,8 +99,9 @@ handle_headers([Header | Headers], NewHeaders, StatusCode) -> _ -> 200 end, - handle_headers(Headers, NewHeaders, NewStatusCode); + handle_headers(Headers, NewHeaders, NewStatusCode, false); _ -> handle_headers(Headers, - [{FieldName, FieldValue}| NewHeaders], StatusCode) - end. + [{FieldName, FieldValue}| NewHeaders], StatusCode, + NoESIStatus) + end. diff --git a/lib/inets/src/http_server/httpd_example.erl b/lib/inets/src/http_server/httpd_example.erl index 45b6deba97..47a8c48d01 100644 --- a/lib/inets/src/http_server/httpd_example.erl +++ b/lib/inets/src/http_server/httpd_example.erl @@ -20,7 +20,7 @@ %% -module(httpd_example). -export([print/1]). --export([get/2, put/2, post/2, yahoo/2, test1/2, get_bin/2, peer/2]). +-export([get/2, put/2, post/2, yahoo/2, test1/2, get_bin/2, peer/2,new_status_and_location/2]). -export([newformat/3, post_chunked/3]). %% These are used by the inets test-suite @@ -90,6 +90,9 @@ post(Env,Input) -> yahoo(_Env,_Input) -> "Location: http://www.yahoo.com\r\n\r\n". +new_status_and_location(_Env,_Input) -> + "status:201 Created\r\n Location: http://www.yahoo.com\r\n\r\n". + default(Env,Input) -> [header(), top("Default Example"), diff --git a/lib/inets/src/http_server/httpd_request.erl b/lib/inets/src/http_server/httpd_request.erl index 0eaf073255..007d272323 100644 --- a/lib/inets/src/http_server/httpd_request.erl +++ b/lib/inets/src/http_server/httpd_request.erl @@ -306,10 +306,10 @@ add_chunk([<<>>, Body, Length, MaxChunk]) -> add_chunk([More, Body, Length, MaxChunk]) -> body_chunk(<<Body/binary, More/binary>>, Length, MaxChunk). -body_chunk(<<>> = Body, Length, MaxChunk) -> - {ok, {continue, ?MODULE, add_chunk, [Body, Length, MaxChunk]}}; body_chunk(Body, Length, nolimit) -> whole_body(Body, Length); +body_chunk(<<>> = Body, Length, MaxChunk) -> + {ok, {continue, ?MODULE, add_chunk, [Body, Length, MaxChunk]}}; body_chunk(Body, Length, MaxChunk) when Length > MaxChunk -> case size(Body) >= MaxChunk of diff --git a/lib/inets/src/http_server/httpd_request_handler.erl b/lib/inets/src/http_server/httpd_request_handler.erl index bd4fdd3832..d918f10424 100644 --- a/lib/inets/src/http_server/httpd_request_handler.erl +++ b/lib/inets/src/http_server/httpd_request_handler.erl @@ -516,6 +516,15 @@ handle_body(#state{headers = Headers, body = Body, case ((Length =< MaxBodySize) or (MaxBodySize == nolimit)) of true -> case httpd_request:body_chunk_first(Body, Length, MaxChunk) of + %% This is the case that the we need more data to complete + %% the body but chunking to the mod_esi user is not enabled. + {Module, add_chunk = Function, Args} -> + http_transport:setopts(ModData#mod.socket_type, + ModData#mod.socket, + [{active, once}]), + {noreply, State#state{mfa = + {Module, Function, Args}}}; + %% Chunking to mod_esi user is enabled {ok, {continue, Module, Function, Args}} -> http_transport:setopts(ModData#mod.socket_type, ModData#mod.socket, @@ -525,6 +534,8 @@ handle_body(#state{headers = Headers, body = Body, {ok, {{continue, Chunk}, Module, Function, Args}} -> handle_internal_chunk(State#state{chunk = chunk_start(MaxChunk), body = Chunk}, Module, Function, Args); + %% Whole body delivered, if chunking mechanism is enabled the whole + %% body fits in one chunk. {ok, NewBody} -> handle_response(State#state{chunk = chunk_finish(ChunkState, CbState, MaxChunk), diff --git a/lib/inets/src/http_server/mod_esi.erl b/lib/inets/src/http_server/mod_esi.erl index 3a589ca5f0..3206d957d9 100644 --- a/lib/inets/src/http_server/mod_esi.erl +++ b/lib/inets/src/http_server/mod_esi.erl @@ -339,26 +339,21 @@ erl_scheme_webpage_whole(Mod, Func, Env, Input, ModData) -> {Headers, Body} = httpd_esi:parse_headers(lists:flatten(Response)), Length = httpd_util:flatlength(Body), - case httpd_esi:handle_headers(Headers) of - {proceed, AbsPath} -> - {proceed, [{real_name, httpd_util:split_path(AbsPath)} - | ModData#mod.data]}; - {ok, NewHeaders, StatusCode} -> - send_headers(ModData, StatusCode, - [{"content-length", - integer_to_list(Length)}| NewHeaders]), - case ModData#mod.method of - "HEAD" -> - {proceed, [{response, {already_sent, 200, 0}} | - ModData#mod.data]}; - _ -> - httpd_response:send_body(ModData, - StatusCode, Body), - {proceed, [{response, {already_sent, 200, - Length}} | - ModData#mod.data]} - end - end + {ok, NewHeaders, StatusCode} = httpd_esi:handle_headers(Headers), + send_headers(ModData, StatusCode, + [{"content-length", + integer_to_list(Length)}| NewHeaders]), + case ModData#mod.method of + "HEAD" -> + {proceed, [{response, {already_sent, 200, 0}} | + ModData#mod.data]}; + _ -> + httpd_response:send_body(ModData, + StatusCode, Body), + {proceed, [{response, {already_sent, 200, + Length}} | + ModData#mod.data]} + end end. %% New API that allows the dynamic wepage to be sent back to the client @@ -398,29 +393,23 @@ deliver_webpage_chunk(#mod{config_db = Db} = ModData, Pid, Timeout) -> {continue, _} = Continue -> Continue; {Headers, Body} -> - case httpd_esi:handle_headers(Headers) of - {proceed, AbsPath} -> - {proceed, [{real_name, httpd_util:split_path(AbsPath)} - | ModData#mod.data]}; - {ok, NewHeaders, StatusCode} -> - IsDisableChunkedSend = - httpd_response:is_disable_chunked_send(Db), - case (ModData#mod.http_version =/= "HTTP/1.1") or - (IsDisableChunkedSend) of - true -> - send_headers(ModData, StatusCode, - [{"connection", "close"} | - NewHeaders]); - false -> - send_headers(ModData, StatusCode, - [{"transfer-encoding", - "chunked"} | NewHeaders]) - end, - handle_body(Pid, ModData, Body, Timeout, length(Body), - IsDisableChunkedSend) - end; - timeout -> - send_headers(ModData, 504, [{"connection", "close"}]), + {ok, NewHeaders, StatusCode} = httpd_esi:handle_headers(Headers), + IsDisableChunkedSend = httpd_response:is_disable_chunked_send(Db), + case (ModData#mod.http_version =/= "HTTP/1.1") or + (IsDisableChunkedSend) of + true -> + send_headers(ModData, StatusCode, + [{"connection", "close"} | + NewHeaders]); + false -> + send_headers(ModData, StatusCode, + [{"transfer-encoding", + "chunked"} | NewHeaders]) + end, + handle_body(Pid, ModData, Body, Timeout, length(Body), + IsDisableChunkedSend); + timeout -> + send_headers(ModData, 504, [{"connection", "close"}]), httpd_socket:close(ModData#mod.socket_type, ModData#mod.socket), {proceed,[{response, {already_sent, 200, 0}} | ModData#mod.data]} end. @@ -560,15 +549,10 @@ eval(#mod{method = Method} = ModData, ESIBody, Modules) {ok, Response} -> {Headers, _} = httpd_esi:parse_headers(lists:flatten(Response)), - case httpd_esi:handle_headers(Headers) of - {ok, _, StatusCode} -> - {proceed,[{response, {StatusCode, Response}} | - ModData#mod.data]}; - {proceed, AbsPath} -> - {proceed, [{real_name, AbsPath} | - ModData#mod.data]} - end - end; + {ok, _, StatusCode} =httpd_esi:handle_headers(Headers), + {proceed,[{response, {StatusCode, Response}} | + ModData#mod.data]} + end; false -> {proceed,[{status, {403, ModData#mod.request_uri, diff --git a/lib/inets/src/inets_app/inets.appup.src b/lib/inets/src/inets_app/inets.appup.src index a86413147c..fdf4cc6e07 100644 --- a/lib/inets/src/inets_app/inets.appup.src +++ b/lib/inets/src/inets_app/inets.appup.src @@ -18,10 +18,14 @@ %% %CopyrightEnd% {"%VSN%", [ + {<<"6.4.3">>, [{load_module, httpd_esi, + soft_purge, soft_purge, []}]}, {<<"6\\..*">>,[{restart_application, inets}]}, {<<"5\\..*">>,[{restart_application, inets}]} ], [ + {<<"6.4.3">>, [{load_module, httpd_esi, + soft_purge, soft_purge, []}]}, {<<"6\\..*">>,[{restart_application, inets}]}, {<<"5\\..*">>,[{restart_application, inets}]} ] diff --git a/lib/inets/test/Makefile b/lib/inets/test/Makefile index ffc512050a..99a7e6a9db 100644 --- a/lib/inets/test/Makefile +++ b/lib/inets/test/Makefile @@ -150,6 +150,7 @@ INETS_ROOT = ../../inets MODULES = \ inets_test_lib \ erl_make_certs \ + make_certs \ ftp_SUITE \ ftp_format_SUITE \ http_format_SUITE \ @@ -157,10 +158,10 @@ MODULES = \ httpc_cookie_SUITE \ httpc_proxy_SUITE \ httpd_SUITE \ - old_httpd_SUITE \ + httpd_bench_SUITE \ + http_test_lib \ httpd_basic_SUITE \ httpd_mod \ - httpd_block \ httpd_load \ httpd_time_test \ httpd_1_1 \ @@ -189,7 +190,7 @@ SOURCE = $(ERL_FILES) $(HRL_FILES) TARGET_FILES = $(MODULES:%=$(EBIN)/%.$(EMULATOR)) -INETS_SPECS = inets.spec +INETS_SPECS = inets.spec inets_bench.spec COVER_FILE = inets.cover INETS_FILES = inets.config $(INETS_SPECS) @@ -200,8 +201,10 @@ INETS_FILES = inets.config $(INETS_SPECS) # inets_ftp_suite \ # inets_tftp_suite + INETS_DATADIRS = inets_SUITE_data inets_socketwrap_SUITE_data -HTTPD_DATADIRS = httpd_test_data httpd_SUITE_data httpd_basic_SUITE_data old_httpd_SUITE_data +HTTPD_DATADIRS = httpd_test_data httpd_SUITE_data httpd_basic_SUITE_data old_httpd_SUITE_data httpd_bench_SUITE_data + HTTPC_DATADIRS = httpc_SUITE_data httpc_proxy_SUITE_data FTP_DATADIRS = ftp_SUITE_data diff --git a/lib/inets/test/http_format_SUITE.erl b/lib/inets/test/http_format_SUITE.erl index 4e10a97f58..647eff4f7c 100644 --- a/lib/inets/test/http_format_SUITE.erl +++ b/lib/inets/test/http_format_SUITE.erl @@ -535,8 +535,11 @@ esi_parse_headers(Config) when is_list(Config) -> {"location","http://foo.bar.se"}], 302} = httpd_esi:handle_headers(Headers2), - {proceed,"/foo/bar.html"} = - httpd_esi:handle_headers("location:/foo/bar.html\r\n"). + {ok,[{"location","/foo/bar.html"}], 302} = + httpd_esi:handle_headers("location:/foo/bar.html\r\n"), + + {ok,[{"location","http://foo/bar.html"}],201} = + httpd_esi:handle_headers("status:201 Created\r\nlocation:http://foo/bar.html\r\n"). %%-------------------------------------------------------------------- cgi_parse_headers() -> diff --git a/lib/inets/test/http_test_lib.erl b/lib/inets/test/http_test_lib.erl new file mode 100644 index 0000000000..38e9e4976e --- /dev/null +++ b/lib/inets/test/http_test_lib.erl @@ -0,0 +1,180 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2015-2015. 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(http_test_lib). + +-include_lib("common_test/include/ct.hrl"). +-include("inets_test_lib.hrl"). +-include("http_internal.hrl"). +-include("httpc_internal.hrl"). + +%% Note: This directive should only be used in test suites. +-compile(export_all). + +dummy_server(SocketType, Inet, Extra) -> + dummy_server(self(), SocketType, Inet, Extra). + +dummy_server(Caller, SocketType, Inet, Extra) -> + Args = [Caller, SocketType, Inet, Extra], + Pid = spawn(?MODULE, dummy_server_init, Args), + receive + {port, Port} -> + {Pid, Port} + end. + +dummy_server_init(Caller, ip_comm, Inet, Extra) -> + ContentCb = proplists:get_value(content_cb, Extra), + BaseOpts = [binary, {packet, 0}, {reuseaddr,true}, {active, false}, {nodelay, true}], + Conf = proplists:get_value(conf, Extra), + {ok, ListenSocket} = gen_tcp:listen(0, [Inet | BaseOpts]), + {ok, Port} = inet:port(ListenSocket), + Caller ! {port, Port}, + dummy_ipcomm_server_loop({httpd_request, parse, [[{max_uri, ?HTTP_MAX_URI_SIZE}, + {max_header, ?HTTP_MAX_HEADER_SIZE}, + {max_version,?HTTP_MAX_VERSION_STRING}, + {max_method, ?HTTP_MAX_METHOD_STRING}, + {max_content_length, ?HTTP_MAX_CONTENT_LENGTH}, + {customize, httpd_custom} + ]]}, + [], ContentCb, Conf, ListenSocket); + +dummy_server_init(Caller, ssl, Inet, Extra) -> + ContentCb = proplists:get_value(content_cb, Extra), + SSLOptions = proplists:get_value(ssl, Extra), + Conf = proplists:get_value(conf, Extra), + BaseOpts = [binary, {reuseaddr,true}, {active, false}, {nodelay, true} | + SSLOptions], + dummy_ssl_server_init(Caller, BaseOpts, Inet, ContentCb, Conf). + +dummy_ssl_server_init(Caller, BaseOpts, Inet, ContentCb, Conf) -> + {ok, ListenSocket} = ssl:listen(0, [Inet | BaseOpts]), + {ok, {_, Port}} = ssl:sockname(ListenSocket), + Caller ! {port, Port}, + dummy_ssl_server_loop({httpd_request, parse, [[{max_uri, ?HTTP_MAX_URI_SIZE}, + {max_method, ?HTTP_MAX_METHOD_STRING}, + {max_version,?HTTP_MAX_VERSION_STRING}, + {max_method, ?HTTP_MAX_METHOD_STRING}, + {max_content_length, ?HTTP_MAX_CONTENT_LENGTH}, + {customize, httpd_custom} + ]]}, + [], ContentCb, Conf, ListenSocket). + +dummy_ipcomm_server_loop(MFA, Handlers, ContentCb, Conf, ListenSocket) -> + receive + stop -> + lists:foreach(fun(Handler) -> Handler ! stop end, Handlers); + {stop, From} -> + Stopper = fun(Handler) -> Handler ! stop end, + lists:foreach(Stopper, Handlers), + From ! {stopped, self()} + after 0 -> + {ok, Socket} = gen_tcp:accept(ListenSocket), + HandlerPid = dummy_request_handler(MFA, Socket, ContentCb, Conf), + gen_tcp:controlling_process(Socket, HandlerPid), + HandlerPid ! ipcomm_controller, + dummy_ipcomm_server_loop(MFA, [HandlerPid | Handlers], + ContentCb, Conf, ListenSocket) + end. + +dummy_ssl_server_loop(MFA, Handlers, ContentCb, Conf, ListenSocket) -> + receive + stop -> + lists:foreach(fun(Handler) -> Handler ! stop end, Handlers); + {stop, From} -> + Stopper = fun(Handler) -> Handler ! stop end, + lists:foreach(Stopper, Handlers), + From ! {stopped, self()} + after 0 -> + {ok, Socket} = ssl:transport_accept(ListenSocket), + HandlerPid = dummy_request_handler(MFA, Socket, ContentCb, Conf), + ssl:controlling_process(Socket, HandlerPid), + HandlerPid ! ssl_controller, + dummy_ssl_server_loop(MFA, [HandlerPid | Handlers], + ContentCb, Conf, ListenSocket) + end. + +dummy_request_handler(MFA, Socket, ContentCb, Conf) -> + spawn(?MODULE, dummy_request_handler_init, [MFA, Socket, ContentCb, Conf]). + +dummy_request_handler_init(MFA, Socket, ContentCb, Conf) -> + SockType = + receive + ipcomm_controller -> + inet:setopts(Socket, [{active, true}]), + ip_comm; + ssl_controller -> + ok = ssl:ssl_accept(Socket, infinity), + ssl:setopts(Socket, [{active, true}]), + ssl + end, + dummy_request_handler_loop(MFA, SockType, Socket, ContentCb, Conf). + +dummy_request_handler_loop({Module, Function, Args}, SockType, Socket, ContentCb, Conf) -> + receive + {Proto, _, Data} when (Proto =:= tcp) orelse (Proto =:= ssl) -> + case handle_request(Module, Function, [Data | Args], Socket, ContentCb, Conf) of + stop when Proto =:= tcp -> + gen_tcp:close(Socket); + stop when Proto =:= ssl -> + ssl:close(Socket); + NewMFA -> + dummy_request_handler_loop(NewMFA, SockType, Socket, ContentCb, Conf) + end; + stop when SockType =:= ip_comm -> + gen_tcp:close(Socket); + stop when SockType =:= ssl -> + ssl:close(Socket) + end. + +handle_request(Module, Function, Args, Socket, ContentCb, Conf) -> + case Module:Function(Args) of + {ok, Result} -> + case ContentCb:handle_http_msg(Result, Socket, Conf) of + stop -> + stop; + <<>> -> + {httpd_request, parse, [[{max_uri,?HTTP_MAX_URI_SIZE}, + {max_header, ?HTTP_MAX_HEADER_SIZE}, + {max_version,?HTTP_MAX_VERSION_STRING}, + {max_method, ?HTTP_MAX_METHOD_STRING}, + {max_content_length, ?HTTP_MAX_CONTENT_LENGTH}, + {customize, httpd_custom} + ]]}; + Data -> + handle_request(httpd_request, parse, + [Data, [{max_uri, ?HTTP_MAX_URI_SIZE}, + {max_header, ?HTTP_MAX_HEADER_SIZE}, + {max_version,?HTTP_MAX_VERSION_STRING}, + {max_method, ?HTTP_MAX_METHOD_STRING}, + {max_content_length, ?HTTP_MAX_CONTENT_LENGTH}, + {customize, httpd_custom} + ]], Socket, ContentCb, Conf) + end; + NewMFA -> + NewMFA + end. + +%% Perform a synchronous stop +dummy_server_stop(Pid) -> + Pid ! {stop, self()}, + receive + {stopped, Pid} -> + ok + end. diff --git a/lib/inets/test/httpc_SUITE.erl b/lib/inets/test/httpc_SUITE.erl index 5dfb1474e5..0533b9ab70 100644 --- a/lib/inets/test/httpc_SUITE.erl +++ b/lib/inets/test/httpc_SUITE.erl @@ -58,7 +58,10 @@ all() -> groups() -> [ {http, [], real_requests()}, - {sim_http, [], only_simulated()}, + %% process_leak_on_keepalive is depending on stream_fun_server_close + %% and it shall be the last test case in the suite otherwise cookie + %% will fail. + {sim_http, [], only_simulated() ++ [process_leak_on_keepalive]}, {https, [], real_requests()}, {sim_https, [], only_simulated()}, {misc, [], misc()} @@ -68,6 +71,7 @@ real_requests()-> [ head, get, + get_query_string, post, delete, post_stream, @@ -115,10 +119,10 @@ only_simulated() -> invalid_chunk_size, headers_dummy, headers_with_obs_fold, + headers_conflict_chunked_with_length, empty_response_header, remote_socket_close, remote_socket_close_async, - process_leak_on_keepalive, transfer_encoding, transfer_encoding_identity, redirect_loop, @@ -127,10 +131,13 @@ only_simulated() -> redirect_found, redirect_see_other, redirect_temporary_redirect, + redirect_relative_uri, port_in_host_header, redirect_port_in_host_header, relaxed, - multipart_chunks + multipart_chunks, + get_space, + stream_fun_server_close ]. misc() -> @@ -242,6 +249,25 @@ get(Config) when is_list(Config) -> {ok, {{_,200,_}, [_ | _], BinBody}} = httpc:request(get, Request, [], [{body_format, binary}]), true = is_binary(BinBody). + + +get_query_string() -> + [{doc, "Test http get request with query string against local server"}]. +get_query_string(Config) when is_list(Config) -> + Request = {url(group_name(Config), "/dummy.html?foo=bar", Config), []}, + {ok, {{_,200,_}, [_ | _], Body = [_ | _]}} = httpc:request(get, Request, [], []), + + inets_test_lib:check_body(Body). + +%%-------------------------------------------------------------------- +get_space() -> + [{"Test http get request with '%20' in the path of the URL."}]. +get_space(Config) when is_list(Config) -> + Request = {url(group_name(Config), "/space%20.html", Config), []}, + {ok, {{_,200,_}, [_ | _], Body = [_ | _]}} = httpc:request(get, Request, [], []), + + inets_test_lib:check_body(Body). + %%-------------------------------------------------------------------- post() -> [{"Test http post request against local server. We do in this case " @@ -575,7 +601,26 @@ redirect_temporary_redirect(Config) when is_list(Config) -> {ok, {{_,200,_}, [_ | _], [_|_]}} = httpc:request(post, {URL307, [],"text/plain", "foobar"}, [], []). +%%------------------------------------------------------------------------- +redirect_relative_uri() -> + [{doc, "The server SHOULD generate a Location header field in the response " + "containing a preferred URI reference for the new permanent URI. The user " + "agent MAY use the Location field value for automatic redirection. The server's " + "response payload usually contains a short hypertext note with a " + "hyperlink to the new URI(s)."}]. +redirect_relative_uri(Config) when is_list(Config) -> + URL301 = url(group_name(Config), "/301_rel_uri.html", Config), + + {ok, {{_,200,_}, [_ | _], [_|_]}} + = httpc:request(get, {URL301, []}, [], []), + + {ok, {{_,200,_}, [_ | _], []}} + = httpc:request(head, {URL301, []}, [], []), + + {ok, {{_,200,_}, [_ | _], [_|_]}} + = httpc:request(post, {URL301, [],"text/plain", "foobar"}, + [], []). %%------------------------------------------------------------------------- redirect_loop() -> [{"doc, Test redirect loop detection"}]. @@ -745,7 +790,7 @@ empty_body() -> empty_body(Config) when is_list(Config) -> URL = url(group_name(Config), "/empty.html", Config), {ok, {{_,200,_}, [_ | _], []}} = - httpc:request(get, {URL, []}, [{timeout, 500}], []). + httpc:request(get, {URL, []}, [], []). %%------------------------------------------------------------------------- @@ -977,7 +1022,6 @@ headers_dummy(Config) when is_list(Config) -> {"If-Range", "Sat, 29 Oct 1994 19:43:31 GMT"}, {"If-Match", "*"}, {"Content-Type", "text/plain"}, - {"Content-Encoding", "chunked"}, {"Content-Length", "6"}, {"Content-Language", "en"}, {"Content-Location", "http://www.foobar.se"}, @@ -1003,6 +1047,18 @@ headers_with_obs_fold(Config) when is_list(Config) -> %%------------------------------------------------------------------------- +headers_conflict_chunked_with_length(doc) -> + ["Test the code for handling headers with both Transfer-Encoding" + "and Content-Length which must receive error in default (not relaxed) mode" + "and must receive successful response in relaxed mode"]; +headers_conflict_chunked_with_length(Config) when is_list(Config) -> + Request = {url(group_name(Config), "/headers_conflict_chunked_with_length.html", Config), []}, + {error, {could_not_parse_as_http, _}} = httpc:request(get, Request, [{relaxed, false}], []), + {ok,{{_,200,_},_,_}} = httpc:request(get, Request, [{relaxed, true}], []), + ok. + +%%------------------------------------------------------------------------- + invalid_headers(Config) -> Request = {url(group_name(Config), "/dummy.html", Config), [{"cookie", undefined}]}, {error, _} = httpc:request(get, Request, [], []). @@ -1042,8 +1098,6 @@ remote_socket_close_async(Config) when is_list(Config) -> %%------------------------------------------------------------------------- process_leak_on_keepalive(Config) -> - {ok, ClosedSocket} = gen_tcp:listen(6666, [{active, false}]), - ok = gen_tcp:close(ClosedSocket), Request = {url(group_name(Config), "/dummy.html", Config), []}, HttpcHandlers0 = supervisor:which_children(httpc_handler_sup), {ok, {{_, 200, _}, _, Body}} = httpc:request(get, Request, [], []), @@ -1055,11 +1109,10 @@ process_leak_on_keepalive(Config) -> ordsets:to_list( ordsets:subtract(ordsets:from_list(HttpcHandlers1), ordsets:from_list(HttpcHandlers0))), - sys:replace_state( - Pid, fun (State) -> - Session = element(3, State), - setelement(3, State, Session#session{socket=ClosedSocket}) - end), + State = sys:get_state(Pid), + #session{socket=Socket} = element(3, State), + gen_tcp:close(Socket), + {ok, {{_, 200, _}, _, Body}} = httpc:request(get, Request, [], []), %% bad handler with the closed socket should get replaced by %% the new one, so children count should stay the same @@ -1178,6 +1231,22 @@ wait_for_whole_response(Config) when is_list(Config) -> ReqSeqNumServer ! shutdown. %%-------------------------------------------------------------------- +stream_fun_server_close() -> + [{doc, "Test that an error msg is received when using a receiver fun as stream target"}]. +stream_fun_server_close(Config) when is_list(Config) -> + Request = {url(group_name(Config), "/delay_close.html", Config), []}, + Self = self(), + Fun = fun(X) -> Self ! X end, + {ok, RequestId} = httpc:request(get, Request, [], [{sync, false}, {receiver, Fun}]), + receive + {RequestId, {error, Reason}} -> + ct:pal("Close ~p", [Reason]), + ok + after 13000 -> + ct:fail(did_not_receive_close) + end. + +%%-------------------------------------------------------------------- %% Internal Functions ------------------------------------------------ %%-------------------------------------------------------------------- stream(ReceiverPid, Receiver, Config) -> @@ -1290,13 +1359,13 @@ group_name(Config) -> server_start(sim_http, _) -> Inet = inet_version(), ok = httpc:set_options([{ipfamily, Inet}]), - {_Pid, Port} = dummy_server(Inet), + {_Pid, Port} = http_test_lib:dummy_server(ip_comm, Inet, [{content_cb, ?MODULE}]), Port; server_start(sim_https, SslConfig) -> Inet = inet_version(), ok = httpc:set_options([{ipfamily, Inet}]), - {_Pid, Port} = dummy_server(ssl, Inet, SslConfig), + {_Pid, Port} = http_test_lib:dummy_server(ssl, Inet, [{ssl, SslConfig}, {content_cb, ?MODULE}]), Port; server_start(_, HttpdConfig) -> @@ -1400,13 +1469,7 @@ receive_replys([ID|IDs]) -> ct:pal({recived_canceld_id, Other}) end. -%% Perform a synchronous stop -dummy_server_stop(Pid) -> - Pid ! {stop, self()}, - receive - {stopped, Pid} -> - ok - end. + inet_version() -> inet. %% Just run inet for now @@ -1534,7 +1597,7 @@ dummy_request_handler_loop({Module, Function, Args}, SockType, Socket) -> handle_request(Module, Function, Args, Socket) -> case Module:Function(Args) of {ok, Result} -> - case handle_http_msg(Result, Socket) of + case handle_http_msg(Result, Socket, []) of stop -> stop; <<>> -> @@ -1559,8 +1622,7 @@ handle_request(Module, Function, Args, Socket) -> NewMFA end. -handle_http_msg({Method, RelUri, _, {_, Headers}, Body}, Socket) -> - +handle_http_msg({Method, RelUri, _, {_, Headers}, Body}, Socket, _) -> ct:print("Request: ~p ~p", [Method, RelUri]), NextRequest = @@ -1684,6 +1746,15 @@ content_length(["content-length:" ++ Value | _]) -> content_length([_Head | Tail]) -> content_length(Tail). +handle_uri("GET","/dummy.html?foo=bar",_,_,_,_) -> + "HTTP/1.0 200 OK\r\n\r\nTEST"; + +handle_uri("GET","/space%20.html",_,_,_,_) -> + Body = "<HTML><BODY>foobar</BODY></HTML>", + "HTTP/1.1 200 OK\r\n" ++ + "Content-Length:" ++ integer_to_list(length(Body)) ++ "\r\n\r\n" ++ + Body; + handle_uri(_,"/just_close.html",_,_,_,_) -> close; handle_uri(_,"/no_content.html",_,_,_,_) -> @@ -1749,6 +1820,23 @@ handle_uri(_,"/301.html",Port,_,Socket,_) -> "Content-Length:" ++ integer_to_list(length(Body)) ++ "\r\n\r\n" ++ Body; + +handle_uri("HEAD","/301_rel_uri.html",_,_,_,_) -> + NewUri = "/dummy.html", + "HTTP/1.1 301 Moved Permanently\r\n" ++ + "Location:" ++ NewUri ++ "\r\n" ++ + "Content-Length:0\r\n\r\n"; + +handle_uri(_,"/301_rel_uri.html",_,_,_,_) -> + NewUri = "/dummy.html", + Body = "<HTML><BODY><a href=" ++ NewUri ++ + ">New place</a></BODY></HTML>", + "HTTP/1.1 301 Moved Permanently\r\n" ++ + "Location:" ++ NewUri ++ "\r\n" ++ + "Content-Length:" ++ integer_to_list(length(Body)) + ++ "\r\n\r\n" ++ Body; + + handle_uri("HEAD","/302.html",Port,_,Socket,_) -> NewUri = url_start(Socket) ++ integer_to_list(Port) ++ "/dummy.html", @@ -1852,7 +1940,6 @@ handle_uri(_,"/dummy_headers.html",_,_,Socket,_) -> %% user to evaluate. This is not a valid response %% it only tests that the header handling code works. Head = "HTTP/1.1 200 ok\r\n" ++ - "Content-Length:32\r\n" ++ "Pragma:1#no-cache\r\n" ++ "Via:1.0 fred, 1.1 nowhere.com (Apache/1.1)\r\n" ++ "Warning:1#pseudonym foobar\r\n" ++ @@ -1882,6 +1969,15 @@ handle_uri(_,"/obs_folded_headers.html",_,_,_,_) -> " b\r\n\r\n" "Hello"; +handle_uri(_,"/headers_conflict_chunked_with_length.html",_,_,Socket,_) -> + Head = "HTTP/1.1 200 ok\r\n" + "Content-Length:32\r\n" + "Transfer-Encoding:Chunked\r\n\r\n", + send(Socket, Head), + send(Socket, http_chunk:encode("<HTML><BODY>fo")), + send(Socket, http_chunk:encode("obar</BODY></HTML>")), + http_chunk:encode_last(); + handle_uri(_,"/capital_transfer_encoding.html",_,_,Socket,_) -> Head = "HTTP/1.1 200 ok\r\n" ++ "Transfer-Encoding:Chunked\r\n\r\n", @@ -2029,6 +2125,9 @@ handle_uri(_,"/multipart_chunks.html",_,_,Socket,_) -> send(Socket, Head), send_multipart_chunks(Socket), http_chunk:encode_last(); +handle_uri(_,"/delay_close.html",_,_,Socket,_) -> + ct:sleep(10000), + close(Socket); handle_uri("HEAD",_,_,_,_,_) -> "HTTP/1.1 200 ok\r\n" ++ "Content-Length:0\r\n\r\n"; diff --git a/lib/inets/test/httpd_SUITE.erl b/lib/inets/test/httpd_SUITE.erl index 6c8728470b..9a85c51d24 100644 --- a/lib/inets/test/httpd_SUITE.erl +++ b/lib/inets/test/httpd_SUITE.erl @@ -129,7 +129,7 @@ groups() -> {http_1_1, [], [host, chunked, expect, cgi, cgi_chunked_encoding_test, trace, range, if_modified_since, mod_esi_chunk_timeout, - esi_put] ++ http_head() ++ http_get() ++ load()}, + esi_put, esi_post] ++ http_head() ++ http_get() ++ load()}, {http_1_0, [], [host, cgi, trace] ++ http_head() ++ http_get() ++ load()}, {http_0_9, [], http_head() ++ http_get() ++ load()} ]. @@ -923,8 +923,11 @@ esi(Config) when is_list(Config) -> {no_header, "cache-control"}]), ok = http_status("GET /cgi-bin/erl/httpd_example:peer ", Config, [{statuscode, 200}, - {header, "peer-cert-exist", peer(Config)}]). - + {header, "peer-cert-exist", peer(Config)}]), + ok = http_status("GET /cgi-bin/erl/httpd_example:new_status_and_location ", + Config, [{statuscode, 201}, + {header, "location"}]). + %%------------------------------------------------------------------------- esi_put() -> [{doc, "Test mod_esi PUT"}]. @@ -932,7 +935,20 @@ esi_put() -> esi_put(Config) when is_list(Config) -> ok = http_status("PUT /cgi-bin/erl/httpd_example/put/123342234123 ", Config, [{statuscode, 200}]). - +%%------------------------------------------------------------------------- +esi_post() -> + [{doc, "Test mod_esi POST"}]. + +esi_post(Config) when is_list(Config) -> + Chunk = "ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ", + Data = lists:duplicate(10000, Chunk), + Length = lists:flatlength(Data), + ok = http_status("POST /cgi-bin/erl/httpd_example/post ", + {"Content-Length:" ++ integer_to_list(Length) ++ "\r\n", + Data}, + [{http_version, "HTTP/1.1"} |Config], + [{statuscode, 200}]). + %%------------------------------------------------------------------------- mod_esi_chunk_timeout(Config) when is_list(Config) -> ok = httpd_1_1:mod_esi_chunk_timeout(proplists:get_value(type, Config), diff --git a/lib/inets/test/httpd_basic_SUITE.erl b/lib/inets/test/httpd_basic_SUITE.erl index 931cd076cc..94d22ea76c 100644 --- a/lib/inets/test/httpd_basic_SUITE.erl +++ b/lib/inets/test/httpd_basic_SUITE.erl @@ -303,7 +303,10 @@ escaped_url_in_error_body(Config) when is_list(Config) -> %% Ask for a non-existing page(1) Path = "/<b>this_is_bold<b>", HTMLEncodedPath = http_util:html_encode(Path), - URL2 = URL1 ++ Path, + URL2 = uri_string:recompose(#{scheme => "http", + host => "localhost", + port => Port, + path => Path}), {ok, {404, Body3}} = httpc:request(get, {URL2, []}, [{url_encode, true}, {version, "HTTP/1.0"}], diff --git a/lib/inets/test/httpd_bench_SUITE.erl b/lib/inets/test/httpd_bench_SUITE.erl new file mode 100644 index 0000000000..9d8cbf9ae2 --- /dev/null +++ b/lib/inets/test/httpd_bench_SUITE.erl @@ -0,0 +1,846 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2012. 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(httpd_bench_SUITE). +-compile(export_all). + +-include_lib("common_test/include/ct.hrl"). +-include_lib("common_test/include/ct_event.hrl"). +-include_lib("public_key/include/public_key.hrl"). +-include_lib("kernel/include/file.hrl"). + +-define(remote_host, "NETMARKS_REMOTE_HOST"). +-define(LF, [10]). +-define(CR, [13]). +-define(CRLF, ?CR ++ ?LF). + +%%-------------------------------------------------------------------- +%% Common Test interface functions ----------------------------------- +%%-------------------------------------------------------------------- +suite() -> + [{ct_hooks,[{ts_install_cth,[{nodenames,2}]}]}]. + +all() -> + [ + {group, http_dummy}, + {group, http_inets}, + {group, http_nginx}, + {group, https_inets}, + {group, https_dummy}, + {group, https_nginx}, + {group, http_dummy_keep_alive}, + {group, http_inets_keep_alive}, + {group, http_nginx_keep_alive}, + {group, https_inets_keep_alive}, + {group, https_dummy_keep_alive}, + {group, https_nginx_keep_alive} + ]. + +groups() -> + [ + {http_dummy, [], client_tests()}, + {http_inets, [], client_tests()}, + {http_nginx, [], client_tests()}, + {https_dummy, [], client_tests()}, + {https_inets, [], client_tests()}, + {https_nginx, [], client_tests()}, + {http_dummy_keep_alive, [], client_tests()}, + {http_inets_keep_alive, [], client_tests()}, + {http_nginx_keep_alive, [], client_tests()}, + {https_dummy_keep_alive, [], client_tests()}, + {https_inets_keep_alive, [], client_tests()}, + {https_nginx_keep_alive, [], client_tests()} + ]. + + +client_tests() -> + [wget_small, + erl_dummy_small, + httpc_small, + wget_big, + erl_dummy_big, + httpc_big + ]. + +init_per_suite(Config) -> + try + {Node, Host} = setup(Config, node()), + init_ssl(Config), + [{iter, 10}, {server_node, Node}, {server_host, Host} | Config] + catch _:_ -> + {skipped, "Benchmark machines only"} + end. + +end_per_suite(_Config) -> + [application:stop(App) || App <- [asn1, crypto, public_key, ssl, inets]]. + +init_per_group(Group, Config) when Group == http_dummy_keep_alive; + Group == https_dummy_keep_alive; + Group == http_inets_keep_alive; + Group == https_inets_keep_alive; + Group == http_nginx_keep_alive; + Group == https_nginx_keep_alive -> + Version = http_version(Group), + start_web_server(Group, + [{keep_alive, true}, + {reuse_sessions, false}, + {http_version, Version}, + {http_opts,[{version, Version}]}, + {http_headers, [{"connection", "keep-alive"}]}, + {httpc_opts, [{keep_alive_timeout, 1500}, + {max_keep_alive_length, ?config(iter, Config)}]} + | Config]); +init_per_group(Group, Config) when Group == http_dummy; + Group == https_dummy; + Group == http_inets; + Group == https_inets; + Group == http_nginx; + Group == https_nginx -> + Version = http_version(Group), + start_web_server(Group, + [{keep_alive, false}, + {reuse_sessions, false}, + {http_version, Version}, + {http_headers, [{"connection", "close"}]}, + {http_opts,[{version, Version}]}, + {httpc_opts, [{keep_alive_timeout, 0}, {max_keep_alive_length, 0}]} + | Config]); + + +init_per_group(_, Config) -> + Config. + +end_per_group(Group, Config) -> + stop_web_server(Group, Config). + +init_per_testcase(TestCase, Config) when TestCase == httpc_small; + TestCase == httpc_big + -> + Opts = ?config(httpc_opts, Config), + inets:start(httpc, [{profile, TestCase}, {socket_opts, [{nodelay, true}]}]), + httpc:set_options(Opts, TestCase), + [{profile, TestCase} | proplists:delete(profile, Config)]; + +init_per_testcase(_, Config) -> + Config. +end_per_testcase(TestCase, _Config) when TestCase == httpc_small; + TestCase == httpc_big -> + ok = inets:stop(httpc, TestCase); +end_per_testcase(_TestCase, Config) -> + Config. +%%-------------------------------------------------------------------- +%% Test Cases -------------------------------------------------------- +%%-------------------------------------------------------------------- + +erl_dummy_small(Config) when is_list(Config) -> + {ok, Result} = run_test(httpd_lib_client, "1k_file", Config), + notify(Result, Config, "erl_1k_file"). + +erl_dummy_big(Config) when is_list(Config) -> + {ok, Result} = run_test(httpd_lib_client, "1M_file", Config), + notify(Result, Config, "erl_1M_file"). + +wget_small(Config) when is_list(Config) -> + {ok, Result} = run_test(wget_client, "1k_file", Config), + notify(Result, Config, "wget_1k_file"). + +wget_big(Config) when is_list(Config) -> + {ok, Result} = run_test(wget_client, "1M_file", Config), + notify(Result, Config, "wget_1M_file"). + +httpc_small(Config) when is_list(Config) -> + {ok, Result} = run_test(httpc_client, "1k_file", Config), + notify(Result, Config, "httpc_1k_file"). + +httpc_big(Config) when is_list(Config) -> + {ok, Result} = run_test(httpc_client, "1M_file", Config), + notify(Result, Config, "httpc_1M_file"). + +%%-------------------------------------------------------------------- +%% Internal functions ------------------------------------------------ +%%-------------------------------------------------------------------- + +%%-------------------------------------------------------------------- +%% Report benchmark results ------------------------------------------------ +%%-------------------------------------------------------------------- + +notify({TestPerSec, _MBps}, Config, Suffix) -> + Name = lists:concat([?config(protocol,Config), " ", + server_name(Config, [dummy_pid, httpd_pid, nginx_port]), + "", Suffix]), + ct:comment("~p tps", [TestPerSec]), + ct_event:notify(#event{name = benchmark_data, + data=[{value, TestPerSec}, + {suite, ?MODULE}, + {name, Name}]}), + ok. +%%-------------------------------------------------------------------- +%% Setup erlang nodes ------------------------------------------------ +%%-------------------------------------------------------------------- + +server_name(Config, [Server | Rest]) -> + case proplists:get_value(Server, Config) of + undefined -> + server_name(Config, Rest); + _ -> + server_name(Server) + end. + +server_name(httpd_pid) -> + "inets"; +server_name(nginx_port) -> + "nginx"; +server_name(dummy_pid) -> + "erlang". + +setup(_Config, nonode@nohost) -> + exit(dist_not_enabled); +setup(_Config, _LocalNode) -> + Host = case os:getenv(?remote_host) of + false -> + {ok, This} = inet:gethostname(), + This; + RemHost -> + RemHost + end, + Node = list_to_atom("inets_perf_server@" ++ Host), + SlaveArgs = case init:get_argument(pa) of + {ok, PaPaths} -> + lists:append([" -pa " ++ P || [P] <- PaPaths]); + _ -> [] + end, + Prog = + case os:find_executable("erl") of + false -> "erl"; + P -> P + end, + case net_adm:ping(Node) of + pong -> ok; + pang -> + {ok, Node} = slave:start(Host, inets_perf_server, SlaveArgs, no_link, Prog) + end, + Path = code:get_path(), + true = rpc:call(Node, code, set_path, [Path]), + [ensure_started(Node, App) || App <- [asn1, crypto, public_key, ssl, inets]], + [ensure_started(node(), App) || App <- [asn1, crypto, public_key, ssl, inets]], + (Node =:= node()) andalso restrict_schedulers(client), + {Node, Host}. + +ensure_started(Node, App) -> + ok = rpc:call(Node, application, ensure_started, [App]). + + +restrict_schedulers(Type) -> + %% We expect this to run on 8 core machine + Extra0 = 1, + Extra = if (Type =:= server) -> -Extra0; true -> Extra0 end, + Scheds = erlang:system_info(schedulers), + erlang:system_flag(schedulers_online, (Scheds div 2) + Extra). + +%%-------------------------------------------------------------------- +%% Setup TLS input files ------------------------------------------------ +%%-------------------------------------------------------------------- + +init_ssl(Config) -> + DDir = ?config(data_dir, Config), + PDir = ?config(priv_dir, Config), + {ok, _} = make_certs:all(DDir, + PDir). +cert_opts(Config) -> + ClientCaCertFile = filename:join([?config(priv_dir, Config), + "client", "cacerts.pem"]), + ClientCertFile = filename:join([?config(priv_dir, Config), + "client", "cert.pem"]), + ServerCaCertFile = filename:join([?config(priv_dir, Config), + "server", "cacerts.pem"]), + ServerCertFile = filename:join([?config(priv_dir, Config), + "server", "cert.pem"]), + ServerKeyFile = filename:join([?config(priv_dir, Config), + "server", "key.pem"]), + ClientKeyFile = filename:join([?config(priv_dir, Config), + "client", "key.pem"]), + [{server_verification_opts, [{reuseaddr, true}, + {cacertfile, ServerCaCertFile}, + {ciphers, ["ECDHE-RSA-AES256-GCM-SHA384"]}, + {certfile, ServerCertFile}, {keyfile, ServerKeyFile}]}, + {client_verification_opts, [ + %%{verify, verify_peer}, + {cacertfile, ClientCaCertFile}, + {certfile, ClientCertFile}, + {keyfile, ClientKeyFile}]}]. + +%%-------------------------------------------------------------------- +%% Run clients ------------------------------------------------ +%%-------------------------------------------------------------------- + +run_test(Client, File, Config) -> + Parent = self(), + Pid = spawn(fun() -> + receive + go -> + Parent ! {self(), + do_runs(Client, [{file, File} | Config])} + end + end), + Pid ! go, + receive + {Pid,{{tps, Tps}, {mbps, MBps}}} -> + ct:pal("Tps: ~p Bps~p", [Tps, MBps]), + {ok, {Tps, MBps}} + end. + +do_runs(Client, Config) -> + N = ?config(iter, Config), + DataDir = ?config(data_dir, Config), + File = ?config(file, Config), + Name = filename:join(DataDir, File), + Args = ?MODULE:Client(Config), + ?MODULE:Client({init, Args}), + Run = + fun() -> + ok = ?MODULE:Client(Args, N) + end, + {ok, Info} = file:read_file_info(Name, []), + Length = Info#file_info.size, + {TimeInMicro, _} = timer:tc(Run), + ReqPerSecond = (1000000 * N) div TimeInMicro, + BytesPerSecond = (1000000 * N * Length) div TimeInMicro, + {{tps, ReqPerSecond}, {mbps, BytesPerSecond}}. + + +httpc_client({init, [_, Profile, URL, Headers, HTTPOpts]}) -> + %% Make sure pipelining feature will kick in when appropriate. + {ok, {{_ ,200, "OK"}, _,_}} = httpc:request(get,{URL, Headers}, HTTPOpts, + [{body_format, binary}, + {socket_opts, [{nodelay, true}]}], Profile), + ct:sleep(1000); +httpc_client(Config) -> + File = ?config(file, Config), + Protocol = ?config(protocol, Config), + Profile = ?config(profile, Config), + URL = (?config(urlfun,Config))(File), + Headers = ?config(http_headers, Config), + HTTPOpts = ?config(http_opts, Config), + [Protocol, Profile, URL, Headers, HTTPOpts]. +httpc_client(_,0) -> + ok; +httpc_client([Protocol, Profile, URL, Headers, HTTPOpts], N) -> + {ok, {{_ ,200,"OK"}, _,_}} = httpc:request(get,{URL, Headers}, HTTPOpts, [{body_format, binary}, + {socket_opts, [{nodelay, true}]}], Profile), + httpc_client([Protocol, Profile, URL, Headers, HTTPOpts], N-1). + +httpd_lib_client({init, [_, Type, Version, Request, Host, Port, Opts]}) -> + ok = httpd_test_lib:verify_request(Type, Host, + Port, + Opts, node(), + Request, + [{statuscode, 200}, + {version, Version}], infinity), + ct:sleep(1000); +httpd_lib_client(Config) -> + File = ?config(file, Config), + KeepAlive = ?config(keep_alive, Config), + Host = ?config(server_host, Config), + Port = ?config(port, Config), + ReuseSession = ?config(reuse_sessions, Config), + {Type, Opts} = + case ?config(protocol, Config) of + "http" -> + {ip_comm, [{active, true}, {mode, binary},{nodelay, true}]}; + "https" -> + SSLOpts = proplists:get_value(client_verification_opts, cert_opts(Config)), + {ssl, [{active, true}, {mode, binary}, {nodelay, true}, + {reuse_sessions, ReuseSession} | SSLOpts]} + + end, + Version = ?config(http_version, Config), + Request = case KeepAlive of + true -> + http_request("GET /" ++ File ++ " ", Version, Host, {"connection:keep-alive\r\n", ""}); + false -> + http_request("GET /" ++ File ++ " ", Version, Host) + end, + + Args = [KeepAlive, Type, Version, Request, Host, Port, Opts], + httpd_lib_client(Args, 1), + Args. + +httpd_lib_client(_, 0) -> + ok; +httpd_lib_client([true, Type, Version, Request, Host, Port, Opts], N) -> + ok = httpd_test_lib:verify_request_N(Type, Host, + Port, + Opts, node(), + Request, + [{statuscode, 200}, + {version, Version}], infinity, N); +httpd_lib_client([false, Type, Version, Request, Host, Port, Opts] = List, N) -> + ok = httpd_test_lib:verify_request(Type, Host, + Port, + Opts, node(), + Request, + [{statuscode, 200}, + {version, Version}], infinity), + httpd_lib_client(List, N-1). + +wget_client({init,_}) -> + ok; +wget_client(Config) -> + File = ?config(file, Config), + URL = (?config(urlfun,Config))(File), + KeepAlive = ?config(keep_alive, Config), + PrivDir = ?config(priv_dir, Config), + Protocol = ?config(protocol, Config), + Iter = ?config(iter, Config), + FileName = filename:join(PrivDir, "wget_req"), + ProtocolOpts = case Protocol of + "http" -> + []; + "https" -> + proplists:get_value(client_verification_opts, cert_opts(Config)) + end, + wget_req_file(FileName,URL,Iter), + [KeepAlive, FileName, URL, Protocol, ProtocolOpts, Iter]. +wget_client([KeepAlive, WgetFile, _URL, Protocol, ProtocolOpts, _], _) -> + process_flag(trap_exit, true), + Cmd = wget_N(KeepAlive, WgetFile, Protocol, ProtocolOpts), + %%ct:pal("Wget cmd: ~p", [Cmd]), + Port = open_port({spawn, Cmd}, [stderr_to_stdout]), + wait_for_wget(Port). + + +%%-------------------------------------------------------------------- +%% Start/stop servers ------------------------------------------------ +%%-------------------------------------------------------------------- +start_web_server(Group, Config) when Group == http_dummy; + Group == http_dummy_keep_alive -> + start_dummy("http", Config); + +start_web_server(Group, Config) when Group == https_dummy; + Group == https_dummy_keep_alive -> + start_dummy("https", Config); + +start_web_server(Group, Config) when Group == http_inets; + Group == http_inets_keep_alive -> + start_inets("http", [], Config); + +start_web_server(Group, Config) when Group == https_inets; + Group == https_inets_keep_alive -> + Opts = proplists:get_value(server_verification_opts, cert_opts(Config)), + ReuseSessions = ?config(reuse_sessions, Config), + SSLConfHttpd = [{socket_type, {essl, + [{nodelay, true}, {reuse_sessions, ReuseSessions} | Opts]}}], + start_inets("https", SSLConfHttpd, Config); + +start_web_server(Group, Config) when Group == http_nginx; + Group == http_nginx_keep_alive -> + case os:find_executable("nginx") of + false -> + {skip, "nginx not found"}; + _ -> + start_nginx("http", Config) + end; + +start_web_server(Group, Config) when Group == https_nginx; + Group == https_nginx_keep_alive -> + case os:find_executable("nginx") of + false -> + {skip, "nginx not found"}; + _ -> + start_nginx("https", cert_opts(Config) ++ Config) + end. + +start_inets(Protocol, ConfHttpd, Config) -> + PrivDir = ?config(priv_dir, Config), + DataDir = ?config(data_dir, Config), + Node = ?config(server_node, Config), + Host = ?config(server_host, Config), + HTTPVersion = ?config(http_version, Config), + Conf = [httpd, [{port,0}, + {http_version, HTTPVersion}, + {ipfamily, inet}, + {server_name, "inets_test"}, + {server_root, PrivDir}, + {document_root, DataDir}, + {keep_alive, ?config(keep_alive, Config)}, + {keep_alive_timeout, 360} + | ConfHttpd]], + {ok, Pid} = rpc:call(Node, inets, start, Conf), + Port = proplists:get_value(port, rpc:call(Node, httpd, info, [Pid])), + F = fun(File) -> + lists:concat([Protocol,"://",Host,":",Port,"/",File]) + end, + [{httpd_pid,Pid},{urlfun,F},{protocol,Protocol},{port,Port} | Config]. + +start_dummy("http"= Protocol, Config) -> + HTTPVersion = ?config(http_version, Config), + Node = ?config(server_node, Config), + %%DataDir= ?config(data_dir, Config), + Host = ?config(server_host, Config), + Conf = [ + %%{big, filename:join(DataDir, "1M_file")}, + %%{small, filename:join(DataDir, "1k_file")}, + {big, {gen, crypto:rand_bytes(1000000)}}, + {small, {gen, crypto:rand_bytes(1000)}}, + {http_version, HTTPVersion}, + {keep_alive, ?config(keep_alive, Config)} + ], + {Pid, Port} = rpc:call(Node, http_test_lib, dummy_server, [ip_comm, inet, [{content_cb, ?MODULE}, {conf, Conf}]]), + F = fun(File) -> + lists:concat([Protocol,"://",Host,":",Port,"/",File]) + end, + [{dummy_pid,Pid},{urlfun,F},{protocol, Protocol},{port,Port} | Config]; + +start_dummy("https" = Protocol, Config) -> + HTTPVersion = ?config(http_version, Config), + Node = ?config(server_node, Config), + %% DataDir= ?config(data_dir, Config), + Host = ?config(server_host, Config), + SSLOpts = proplists:get_value(server_verification_opts, cert_opts(Config)), + Opts = [{active, true}, {nodelay, true}, {reuseaddr, true} | SSLOpts], + Conf = [%%{big, filename:join(DataDir, "1M_file")}, + %%{small, filename:join(DataDir, "1k_file")}, + {big, {gen, crypto:rand_bytes(1000000)}}, + {small, {gen, crypto:rand_bytes(1000)}}, + {http_version, HTTPVersion}, + {keep_alive, ?config(keep_alive, Config)} + ], + {Pid, Port} = rpc:call(Node, http_test_lib, dummy_server, + [ssl, inet, [{ssl, Opts}, {content_cb, ?MODULE}, {conf, Conf}]]), + F = fun(File) -> + lists:concat([Protocol,"://",Host,":",Port,"/",File]) + end, + [{dummy_pid,Pid},{urlfun,F},{protocol,Protocol},{port,Port} | Config]. + +start_nginx(Protocol, Config) -> + PrivDir = ?config(priv_dir, Config), + DataDir = ?config(data_dir, Config), + Host = ?config(server_host, Config), + Port = inet_port(node()), + + ConfFile = filename:join(PrivDir, "nginx.conf"), + nginx_conf(ConfFile, [{port, Port}, {protocol, Protocol} | Config]), + Cmd = "nginx -c " ++ ConfFile, + NginxPort = open_port({spawn, Cmd}, [{cd, DataDir}, stderr_to_stdout]), + + F = fun(File) -> + lists:concat([Protocol,"://",Host,":",Port,"/",File]) + end, + + wait_for_nginx_up(Host, Port), + + [{port, Port},{nginx_port, NginxPort},{urlfun,F},{protocol, Protocol} | Config ]. + +stop_nginx(Config)-> + PrivDir = ?config(priv_dir, Config), + {ok, Bin} = file:read_file(filename:join(PrivDir, "nginx.pid")), + Pid = string:strip(binary_to_list(Bin), right, $\n), + Cmd = "kill " ++ Pid, + os:cmd(Cmd). + +stop_web_server(Group, Config) when Group == http_inets; + Group == http_inets_keep_alive; + Group == https_inets; + Group == https_inets_keep_alive -> + ServerNode = ?config(server_node, Config), + rpc:call(ServerNode, inets, stop, [httpd, ?config(httpd_pid, Config)]); +stop_web_server(Group, Config) when Group == http_dummy; + Group == http_dummy_keep_alive; + Group == https_dummy; + Group == https_dummy_keep_alive -> + stop_dummy_server(Config); +stop_web_server(Group, Config) when Group == http_nginx; + Group == http_nginx_keep_alive; + Group == https_nginx; + Group == https_nginx_keep_alive -> + stop_nginx(Config). + +stop_dummy_server(Config) -> + case ?config(dummy_pid, Config) of + Pid when is_pid(Pid) -> + exit(Pid, kill); + _ -> + ok + end. + +%%-------------------------------------------------------------------- +%% Misc ------------------------------------------------ +%%-------------------------------------------------------------------- +http_request(Request, "HTTP/1.1" = Version, Host, {Headers, Body}) -> + Request ++ Version ++ "\r\nhost:" ++ Host ++ "\r\n" ++ Headers ++ "\r\n" ++ Body; +http_request(Request, Version, _, {Headers, Body}) -> + Request ++ Version ++ "\r\n" ++ Headers ++ "\r\n" ++ Body. + +http_request(Request, "HTTP/1.1" = Version, Host) -> + Request ++ Version ++ "\r\nhost:" ++ Host ++ "\r\n\r\n"; +http_request(Request, Version, _) -> + Request ++ Version ++ "\r\n\r\n". + +http_version(_) -> + "HTTP/1.1". + +inet_port(Node) -> + {Port, Socket} = do_inet_port(Node), + rpc:call(Node, gen_tcp, close, [Socket]), + Port. + +do_inet_port(Node) -> + {ok, Socket} = rpc:call(Node, gen_tcp, listen, [0, [{reuseaddr, true}]]), + {ok, Port} = rpc:call(Node, inet, port, [Socket]), + {Port, Socket}. + +%%-------------------------------------------------------------------- +%% Dummy server callbacks ------------------------------------------------ +%%-------------------------------------------------------------------- + +handle_request(CB, S, "/1M_file" ++ _, Opts) -> + Name = proplists:get_value(big, Opts), + KeepAlive = proplists:get_value(keep_alive, Opts), + do_handle_request(CB, S, Name, Opts, KeepAlive); +handle_request(CB, S, "/1k_file" ++ _, Opts) -> + Name = proplists:get_value(small, Opts), + KeepAlive = proplists:get_value(keep_alive, Opts), + do_handle_request(CB, S, Name, Opts, KeepAlive). + +do_handle_request(CB, S, Name, Opts, KeepAlive) when is_list(Name) -> + Version = proplists:get_value(http_version, Opts), + {ok, Fdesc} = file:open(Name, [read, binary]), + {ok, Info} = file:read_file_info(Name, []), + Length = Info#file_info.size, + Response = response_status_line_and_headers(Version, "Content-Length:" + ++ integer_to_list(Length) ++ ?CRLF, keep_alive(KeepAlive)), + CB:send(S, Response), + send_file(CB, S, Fdesc); +do_handle_request(CB, S, {gen, Data}, Opts, KeepAlive) -> + Version = proplists:get_value(http_version, Opts), + Length = size(Data), + Response = response_status_line_and_headers(Version, "Content-Length:" + ++ integer_to_list(Length) ++ ?CRLF, keep_alive(KeepAlive)), + CB:send(S, Response), + send_file(CB, S, {gen, Data}). + +send_file(CB, S, {gen, Data}) -> + CB:send(S, Data); + %% ChunkSize = 64*1024, + %% case size(Data) of + %% N when N > ChunkSize -> + %% <<Chunk:N/binary, Rest/binary>> = Data, + %% %%{Chunk, Rest} = lists:split(N, Data), + %% CB:send(S, Chunk), + %% send_file(CB, S, {gen, Rest}); + %% _ -> + %% CB:send(S, Data) + %% end; + +send_file(CB, S, FileDesc) -> + case file:read(FileDesc, 64*1024) of + {ok, Chunk} -> + CB:send(S, Chunk), + send_file(CB, S, FileDesc); + eof -> + file:close(FileDesc), + ok + end. + +response_status_line_and_headers(Version, Headers, ConnectionHeader) -> + StatusLine = [Version, " ", "200 OK", ?CRLF], + [StatusLine, Headers, ConnectionHeader, ?CRLF]. + +keep_alive(true)-> + "Connection:keep-alive\r\n"; +keep_alive(false) -> + "Connection:close\r\n". + +handle_http_msg({_Method, RelUri, _, {_, _Headers}, _Body}, Socket, Conf) -> + handle_request(connect_cb(Socket), Socket, RelUri, Conf), + case proplists:get_value(keep_alive, Conf) of + true -> + <<>>; + false -> + stop + end. + +connect_cb({sslsocket, _, _}) -> + ssl; +connect_cb(_) -> + gen_tcp. + +%%-------------------------------------------------------------------- +%% Setup wget ------------------------------------------------ +%%-------------------------------------------------------------------- +wget_req_file(FileName, Url, Iter) -> + {ok, File} = file:open(FileName, [write]), + write_urls(File, Url, Iter). + +write_urls(File, Url, 1) -> + file:write(File, Url), + file:close(File); +write_urls(File, Url, N) -> + file:write(File, Url), + file:write(File, "\n"), + write_urls(File, Url, N-1). + +wait_for_wget(Port) -> + receive + {Port, {data, _Data}} when is_port(Port) -> + wait_for_wget(Port); + {Port, closed} -> + ok; + {'EXIT', Port, _Reason} -> + ok + end. + +wget_N(KeepAlive, WegetFile, "http", _ProtocolOpts) -> + "wget -i " ++ WegetFile ++ " " ++ wget_keep_alive(KeepAlive) ++ + " --no-cache --timeout=120" ; +wget_N(KeepAlive, WegetFile, "https", ProtocolOpts) -> + + "wget -i " ++ WegetFile ++ " " ++ wget_keep_alive(KeepAlive) + ++ wget_cert(ProtocolOpts) ++ wget_key(ProtocolOpts) + ++ wget_cacert(ProtocolOpts) ++ + " --no-cache --timeout=120". + +wget(KeepAlive, URL, "http", _ProtocolOpts) -> + "wget " ++ URL ++ " " ++ wget_keep_alive(KeepAlive) ++ + " --no-cache --timeout=120" ; +wget(KeepAlive, URL, "https", ProtocolOpts) -> + + "wget " ++ URL ++ " " ++ wget_keep_alive(KeepAlive) + ++ wget_cert(ProtocolOpts) ++ wget_key(ProtocolOpts) + ++ wget_cacert(ProtocolOpts) ++ + " --no-cache --timeout=120". + +wget_keep_alive(true)-> + ""; +wget_keep_alive(false) -> + "--no-http-keep-alive ". + +wget_cacert(ProtocolOpts) -> + "--ca-certificate=" ++ proplists:get_value(cacertfile, ProtocolOpts) ++ " ". + +wget_cert(ProtocolOpts) -> + "--certificate=" ++ proplists:get_value(certfile, ProtocolOpts) ++ " ". + +wget_key(ProtocolOpts) -> + "--private-key=" ++ proplists:get_value(keyfile, ProtocolOpts) ++ " ". + +%%-------------------------------------------------------------------- +%% Setup nginx ------------------------------------------------ +%%-------------------------------------------------------------------- +nginx_conf(ConfFile, Config)-> + Protocol = ?config(protocol, Config), + file:write_file(ConfFile, + [format_nginx_conf(nginx_global(Config)), + format_nginx_conf(nginx_events(Config)), + format_nginx_conf(nginx_http(Protocol, Config))]). + +format_nginx_conf(Directives) -> + lists:map(fun({Key, Value}) -> + io_lib:format("~s ~s;\n", [Key, Value]); + (Str) -> + Str + end, Directives). + + +nginx_global(Config) -> + PrivDir = ?config(priv_dir, Config), + [{"pid", filename:join(PrivDir, "nginx.pid")}, + {"error_log", filename:join(PrivDir, "nginx.pid")}, + {"worker_processes", "1"}]. + +nginx_events(_Config) -> + ["events {\n", + {"worker_connections", "1024"}, + "\n}" + ]. + +nginx_http("http", Config) -> + PrivDir = ?config(priv_dir, Config), + DataDir = ?config(data_dir, Config), + Port = ?config(port, Config), + ["http {\n" | + nginx_defaults(PrivDir) ++ + [" server {", + {root, DataDir}, + {listen, integer_to_list(Port)}, + " location / {\n try_files $uri $uri/ /index.html;\n}" + "}\n", "}\n" + ] + ]; + +nginx_http("https", Config) -> + PrivDir = ?config(priv_dir, Config), + DataDir = ?config(data_dir, Config), + Port = ?config(port, Config), + SSLOpts = ?config(server_verification_opts, Config), + Ciphers = proplists:get_value(ciphers, SSLOpts), + ReuseSession = ?config(reuse_sessions, Config), + ["http {" | + nginx_defaults(PrivDir) ++ + [" server {", + {"root", DataDir}, + {"listen", integer_to_list(Port) ++ " ssl"}, + {"ssl_certificate", ?config(certfile, SSLOpts)}, + {"ssl_certificate_key", ?config(keyfile, SSLOpts)}, + {"ssl_protocols", "TLSv1 TLSv1.1 TLSv1.2"}, + {"ssl_ciphers", Ciphers}, + {"ssl_session_cache", nginx_reuse_session(ReuseSession)}, + " location / {\n try_files $uri $uri/ /index.html;\n}" + "}\n", "}\n" + ] + ]. + +nginx_defaults(PrivDir) -> + [ + %% Set temp and cache file options that will otherwise default to + %% restricted locations accessible only to root. + {"client_body_temp_path", filename:join(PrivDir, "client_body")}, + {"fastcgi_temp_path", filename:join(PrivDir, "fastcgi_temp")}, + {"proxy_temp_path", filename:join(PrivDir, "proxy_temp")}, + {"scgi_temp_path", filename:join(PrivDir, "scgi_temp")}, + {"uwsgi_temp_path", filename:join(PrivDir, "uwsgi_temp_path")}, + {"access_log", filename:join(PrivDir, "access.log")}, + {"error_log", filename:join(PrivDir, "error.log")}, + %% Standard options + {"sendfile", "on"}, + {"tcp_nopush", "on"}, + {"tcp_nodelay", "on"}, + {"keepalive_timeout", "360"}, + {"types_hash_max_size", "2048"}, + {"include", "/etc/nginx/mime.types"}, + {"default_type", "application/octet-stream"} + ]. + +nginx_reuse_session(true) -> + "on"; +nginx_reuse_session(false) -> + "off". + +wait_for_nginx_up(Host, Port) -> + case gen_tcp:connect(Host, Port, []) of + {ok, Socket} -> + gen_tcp:close(Socket); + _ -> + ct:sleep(100), + wait_for_nginx_up(Host, Port) + end. + diff --git a/lib/inets/test/httpd_bench_SUITE_data/1M_file b/lib/inets/test/httpd_bench_SUITE_data/1M_file Binary files differnew file mode 100644 index 0000000000..557989144e --- /dev/null +++ b/lib/inets/test/httpd_bench_SUITE_data/1M_file diff --git a/lib/inets/test/httpd_bench_SUITE_data/1k_file b/lib/inets/test/httpd_bench_SUITE_data/1k_file Binary files differnew file mode 100644 index 0000000000..cade172d80 --- /dev/null +++ b/lib/inets/test/httpd_bench_SUITE_data/1k_file diff --git a/lib/inets/test/httpd_block.erl b/lib/inets/test/httpd_block.erl deleted file mode 100644 index 45547e6d4e..0000000000 --- a/lib/inets/test/httpd_block.erl +++ /dev/null @@ -1,372 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2005-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(httpd_block). - --include_lib("common_test/include/ct.hrl"). - -%% General testcases bodies called from httpd_SUITE --export([block_disturbing_idle/4, block_non_disturbing_idle/4, - block_503/4, block_disturbing_active/4, - block_non_disturbing_active/4, - block_disturbing_active_timeout_not_released/4, - block_disturbing_active_timeout_released/4, - block_non_disturbing_active_timeout_not_released/4, - block_non_disturbing_active_timeout_released/4, - disturbing_blocker_dies/4, - non_disturbing_blocker_dies/4, restart_no_block/4, - restart_disturbing_block/4, restart_non_disturbing_block/4 - ]). - -%% Help functions --export([httpd_block/3, httpd_block/4, httpd_unblock/2, httpd_restart/2]). --export([do_block_server/4, do_block_nd_server/5, do_long_poll/6]). - --define(report(Label, Content), - inets:report_event(20, Label, test_case, - [{module, ?MODULE}, {line, ?LINE} | Content])). - - -%%------------------------------------------------------------------------- -%% Test cases starts here. -%%------------------------------------------------------------------------- -block_disturbing_idle(_Type, Port, Host, Node) -> - io:format("block_disturbing_idle -> entry~n", []), - validate_admin_state(Node, Host, Port, unblocked), - block_server(Node, Host, Port), - validate_admin_state(Node, Host, Port, blocked), - unblock_server(Node, Host, Port), - validate_admin_state(Node, Host, Port, unblocked), - io:format("block_disturbing_idle -> done~n", []), - ok. - -%%-------------------------------------------------------------------- -block_non_disturbing_idle(_Type, Port, Host, Node) -> - unblocked = get_admin_state(Node, Host, Port), - block_nd_server(Node, Host, Port), - blocked = get_admin_state(Node, Host, Port), - unblock_server(Node, Host, Port), - unblocked = get_admin_state(Node, Host, Port), - ok. - -%%-------------------------------------------------------------------- -block_503(Type, Port, Host, Node) -> - Req = "GET / HTTP/1.0\r\ndummy-host.ericsson.se:\r\n\r\n", - unblocked = get_admin_state(Node, Host, Port), - ok = httpd_test_lib:verify_request(Type, Host, Port, Node, Req, - [{statuscode, 200}, - {version, "HTTP/1.0"}]), - ok = block_server(Node, Host, Port), - blocked = get_admin_state(Node, Host, Port), - ok = httpd_test_lib:verify_request(Type, Host, Port, Node, Req, - [{statuscode, 503}, - {version, "HTTP/1.0"}]), - ok = unblock_server(Node, Host, Port), - unblocked = get_admin_state(Node, Host, Port), - ok = httpd_test_lib:verify_request(Type, Host, Port, Node, Req, - [{statuscode, 200}, - {version, "HTTP/1.0"}]). - -%%-------------------------------------------------------------------- -block_disturbing_active(Type, Port, Host, Node) -> - process_flag(trap_exit, true), - Pid = long_poll(Type, Host, Port, Node, 200, 60000), - ct:sleep(15000), - block_server(Node, Host, Port), - await_suite_failed_process_exit(Pid, "poller", 60000, - connection_closed), - blocked = get_admin_state(Node, Host, Port), - process_flag(trap_exit, false), - ok. - -%%-------------------------------------------------------------------- -block_non_disturbing_active(Type, Port, Host, Node) -> - process_flag(trap_exit, true), - Poller = long_poll(Type, Host, Port, Node, 200, 60000), - ct:sleep(15000), - ok = block_nd_server(Node, Host, Port), - await_normal_process_exit(Poller, "poller", 60000), - blocked = get_admin_state(Node, Host, Port), - process_flag(trap_exit, false), - ok. - -%%-------------------------------------------------------------------- -block_disturbing_active_timeout_not_released(Type, Port, Host, Node) -> - process_flag(trap_exit, true), - Poller = long_poll(Type, Host, Port, Node, 200, 60000), - ct:sleep(15000), - ok = httpd_block(undefined, Port, disturbing, 50000), - await_normal_process_exit(Poller, "poller", 30000), - blocked = get_admin_state(Node, Host, Port), - process_flag(trap_exit, false), - ok. - -%%-------------------------------------------------------------------- -block_disturbing_active_timeout_released(Type, Port, Host, Node) -> - process_flag(trap_exit, true), - Poller = long_poll(Type, Host, Port, Node, 200, 40000), - ct:sleep(5000), - ok = httpd_block(undefined, Port, disturbing, 10000), - await_suite_failed_process_exit(Poller, "poller", 40000, - connection_closed), - blocked = get_admin_state(Node, Host, Port), - process_flag(trap_exit, false), - ok. -%%-------------------------------------------------------------------- -block_non_disturbing_active_timeout_not_released(Type, Port, Host, Node) -> - process_flag(trap_exit, true), - Poller = long_poll(Type, Host, Port, Node, 200, 60000), - ct:sleep(5000), - ok = block_nd_server(Node, Host, Port, 40000), - await_normal_process_exit(Poller, "poller", 60000), - blocked = get_admin_state(Node, Host, Port), - process_flag(trap_exit, false), - ok. - -%%-------------------------------------------------------------------- -block_non_disturbing_active_timeout_released(Type, Port, Host, Node) -> - process_flag(trap_exit, true), - Poller = long_poll(Type, Host, Port, Node, 200, 45000), - ct:sleep(5000), - Blocker = blocker_nd(Node, Host, Port ,10000, {error,timeout}), - await_normal_process_exit(Blocker, "blocker", 15000), - await_normal_process_exit(Poller, "poller", 50000), - unblocked = get_admin_state(Node, Host, Port), - process_flag(trap_exit, false), - ok. -%%-------------------------------------------------------------------- -disturbing_blocker_dies(Type, Port, Host, Node) -> - process_flag(trap_exit, true), - Poller = long_poll(Type, Host, Port, Node, 200, 60000), - ct:sleep(5000), - Blocker = blocker(Node, Host, Port, 10000), - ct:sleep(5000), - exit(Blocker,simulate_blocker_crash), - await_normal_process_exit(Poller, "poller", 60000), - unblocked = get_admin_state(Node, Host, Port), - process_flag(trap_exit, false), - ok. - -%%-------------------------------------------------------------------- -non_disturbing_blocker_dies(Type, Port, Host, Node) -> - process_flag(trap_exit, true), - Poller = long_poll(Type, Host, Port, Node, 200, 60000), - ct:sleep(5000), - Blocker = blocker_nd(Node, Host, Port, 10000, ok), - ct:sleep(5000), - exit(Blocker, simulate_blocker_crash), - await_normal_process_exit(Poller, "poller", 60000), - unblocked = get_admin_state(Node, Host, Port), - process_flag(trap_exit, false), - ok. -%%-------------------------------------------------------------------- -restart_no_block(_, Port, Host, Node) -> - {error,_Reason} = restart_server(Node, Host, Port). - -%%-------------------------------------------------------------------- -restart_disturbing_block(_, Port, Host, Node) -> - ?report("restart_disturbing_block - get_admin_state (unblocked)", []), - unblocked = get_admin_state(Node, Host, Port), - ?report("restart_disturbing_block - block_server", []), - ok = block_server(Node, Host, Port), - ?report("restart_disturbing_block - restart_server", []), - ok = restart_server(Node, Host, Port), - ?report("restart_disturbing_block - unblock_server", []), - ok = unblock_server(Node, Host, Port), - ?report("restart_disturbing_block - get_admin_state (unblocked)", []), - unblocked = get_admin_state(Node, Host, Port). - -%%-------------------------------------------------------------------- -restart_non_disturbing_block(_, Port, Host, Node) -> - ?report("restart_non_disturbing_block - get_admin_state (unblocked)", []), - unblocked = get_admin_state(Node, Host, Port), - ?report("restart_non_disturbing_block - block_nd_server", []), - ok = block_nd_server(Node, Host, Port), - ?report("restart_non_disturbing_block - restart_server", []), - ok = restart_server(Node, Host, Port), - ?report("restart_non_disturbing_block - unblock_server", []), - ok = unblock_server(Node, Host, Port), - ?report("restart_non_disturbing_block - get_admin_state (unblocked)", []), - unblocked = get_admin_state(Node, Host, Port). - -%%-------------------------------------------------------------------- -%% Internal functions -%%-------------------------------------------------------------------- -blocker(Node, Host, Port, Timeout) -> - spawn_link(?MODULE, do_block_server,[Node, Host, Port,Timeout]). - -do_block_server(Node, Host, Port, Timeout) -> - ok = block_server(Node, Host, Port, Timeout), - exit(normal). - -blocker_nd(Node, Host, Port, Timeout, Reply) -> - spawn_link(?MODULE, do_block_nd_server, - [Node, Host, Port, Timeout, Reply]). - -do_block_nd_server(Node, Host, Port, Timeout, Reply) -> - Reply = block_nd_server(Node, Host, Port, Timeout), - exit(normal). - -restart_server(Node, _Host, Port) -> - Addr = undefined, - rpc:call(Node, ?MODULE, httpd_restart, [Addr, Port]). - - -block_server(Node, _Host, Port) -> - io:format("block_server -> entry~n", []), - Addr = undefined, - rpc:call(Node, ?MODULE, httpd_block, [Addr, Port, disturbing]). - - -block_server(Node, _Host, Port, Timeout) -> - Addr = undefined, - rpc:call(Node, ?MODULE, httpd_block, [Addr, Port, disturbing, Timeout]). - - -block_nd_server(Node, _Host, Port) -> - Addr = undefined, - rpc:call(Node, ?MODULE, httpd_block, [Addr, Port, non_disturbing]). - -block_nd_server(Node, _Host, Port, Timeout) -> - Addr = undefined, - rpc:call(Node, ?MODULE, httpd_block, [Addr, Port, non_disturbing, Timeout]). - -unblock_server(Node, _Host, Port) -> - io:format("~p:~p:block_server -> entry~n", [node(),self()]), - Addr = undefined, - rpc:call(Node, ?MODULE, httpd_unblock, [Addr, Port]). - - -httpd_block(Addr, Port, Mode) -> - io:format("~p:~p:httpd_block -> entry~n", [node(),self()]), - Name = make_name(Addr, Port), - case whereis(Name) of - Pid when is_pid(Pid) -> - httpd_manager:block(Pid, Mode); - _ -> - {error, not_started} - end. - -httpd_block(Addr, Port, Mode, Timeout) -> - Name = make_name(Addr, Port), - case whereis(Name) of - Pid when is_pid(Pid) -> - httpd_manager:block(Pid, Mode, Timeout); - _ -> - {error, not_started} - end. - -httpd_unblock(Addr, Port) -> - io:format("~p:~p:httpd_unblock -> entry~n", [node(),self()]), - Name = make_name(Addr, Port), - case whereis(Name) of - Pid when is_pid(Pid) -> - httpd_manager:unblock(Pid); - _ -> - {error, not_started} - end. - -httpd_restart(Addr, Port) -> - Name = make_name(Addr, Port), - case whereis(Name) of - Pid when is_pid(Pid) -> - httpd_manager:reload(Pid, undefined); - _ -> - {error, not_started} - end. - -make_name(Addr, Port) -> - httpd_util:make_name("httpd", Addr, Port, default). - -get_admin_state(_, _Host, Port) -> - Name = make_name(undefined, Port), - {status, _, _, StatusInfo} = sys:get_status(whereis(Name)), - [_, _,_, _, Prop] = StatusInfo, - State = state(Prop), - element(6, State). - -validate_admin_state(Node, Host, Port, Expect) -> - io:format("try validating server admin state: ~p~n", [Expect]), - case get_admin_state(Node, Host, Port) of - Expect -> - ok; - Unexpected -> - io:format("failed validating server admin state: ~p~n", - [Unexpected]), - exit({unexpected_admin_state, Unexpected, Expect}) - end. - - -await_normal_process_exit(Pid, Name, Timeout) -> - receive - {'EXIT', Pid, normal} -> - ok; - {'EXIT', Pid, Reason} -> - Err = - lists:flatten( - io_lib:format("expected normal exit, " - "unexpected exit of ~s process: ~p", - [Name, Reason])), - ct:fail(Err) - after Timeout -> - ct:fail("timeout while waiting for " ++ Name) - end. - - -await_suite_failed_process_exit(Pid, Name, Timeout, Why) -> - receive - {'EXIT', Pid, {test_failed, Why}} -> - ok; - {'EXIT', Pid, Reason} -> - Err = - lists:flatten( - io_lib:format("expected connection_closed, " - "unexpected exit of ~s process: ~p", - [Name, Reason])), - ct:fail(Err) - after Timeout -> - ct:fail("timeout while waiting for " ++ Name) - end. - -long_poll(Type, Host, Port, Node, StatusCode, Timeout) -> - spawn_link(?MODULE, do_long_poll, [Type, Host, Port, Node, - StatusCode, Timeout]). - -do_long_poll(Type, Host, Port, Node, StatusCode, Timeout) -> - Mod = "httpd_example", - Func = "delay", - Req = lists:flatten(io_lib:format("GET /eval?" ++ Mod ++ ":" ++ Func ++ - "(~p) HTTP/1.0\r\n\r\n",[30000])), - case httpd_test_lib:verify_request(Type, Host, Port, Node, Req, - [{statuscode, StatusCode}, - {version, "HTTP/1.0"}], Timeout) of - ok -> - exit(normal); - Reason -> - exit({test_failed, Reason}) - end. - - -state([{data,[{"State", State}]} | _]) -> - State; -state([{data,[{"StateData", State}]} | _]) -> - State; -state([_ | Rest]) -> - state(Rest). diff --git a/lib/inets/test/httpd_mod.erl b/lib/inets/test/httpd_mod.erl index d9118aa1a4..2035b50248 100644 --- a/lib/inets/test/httpd_mod.erl +++ b/lib/inets/test/httpd_mod.erl @@ -779,9 +779,14 @@ esi(Type, Port, Host, Node) -> [{statuscode, 200}, {no_header, "cache-control"}, {version, "HTTP/1.0"}]), + ok = httpd_test_lib:verify_request(Type, Host, Port, Node, + "GET /cgi-bin/erl/httpd_example:new_status_and_location" + " HTTP/1.1\r\n\r\n", + [{statuscode, 201}, + {header, "Location"}, + {version, "HTTP/1.1"}]), ok. - %%-------------------------------------------------------------------- get(Type, Port, Host, Node) -> ok = httpd_test_lib:verify_request(Type, Host, Port, Node, diff --git a/lib/inets/test/httpd_test_lib.erl b/lib/inets/test/httpd_test_lib.erl index 1cecd2642c..b6525037b2 100644 --- a/lib/inets/test/httpd_test_lib.erl +++ b/lib/inets/test/httpd_test_lib.erl @@ -23,7 +23,8 @@ -include("inets_test_lib.hrl"). %% Poll functions --export([verify_request/6, verify_request/7, verify_request/8, is_expect/1]). +-export([verify_request/6, verify_request/7, verify_request/8, is_expect/1, + verify_request_N/9]). -record(state, {request, % string() socket, % socket() @@ -109,9 +110,9 @@ verify_request(SocketType, Host, Port, TranspOpts, Node, RequestStr, Options, Ti {error, Reason}; NewState -> ValidateResult = - validate(RequestStr, NewState, Options, Node, Port), + validate(RequestStr, NewState, Options, Node, Port), inets_test_lib:close(SocketType, Socket), - ValidateResult + ValidateResult end; ConnectError -> @@ -126,6 +127,46 @@ verify_request(SocketType, Host, Port, TranspOpts, Node, RequestStr, Options, Ti {args, [SocketType, Host, Port, TranspOpts]}]}) end. +verify_request_N(SocketType, Host, Port, TranspOpts, Node, RequestStr, Options, TimeOut, N) -> + State = #state{}, + try inets_test_lib:connect_bin(SocketType, Host, Port, TranspOpts) of + {ok, Socket} -> + request_N(SocketType, Socket, RequestStr, Options, TimeOut, Node, Port, State, N); + ConnectError -> + ct:fail({connect_error, ConnectError, + [SocketType, Host, Port, TranspOpts]}) + catch + T:E -> + ct:fail({connect_failure, + [{type, T}, + {error, E}, + {stacktrace, erlang:get_stacktrace()}, + {args, [SocketType, Host, Port, TranspOpts]}]}) + end. + +request_N(SocketType, Socket, RequestStr, Options, TimeOut, Node, Port, State, 0) -> + ok = inets_test_lib:send(SocketType, Socket, RequestStr), + case request(State#state{request = RequestStr, + socket = Socket}, TimeOut) of + {error, Reason} -> + {error, Reason}; + NewState -> + ValidateResult = + validate(RequestStr, NewState, Options, Node, Port), + inets_test_lib:close(SocketType, Socket), + ValidateResult + end; +request_N(SocketType, Socket, RequestStr, Options, TimeOut, Node, Port, State, N) -> + ok = inets_test_lib:send(SocketType, Socket, RequestStr), + case request(State#state{request = RequestStr, + socket = Socket}, TimeOut) of + {error, Reason} -> + {error, Reason}; + _NewState -> + request_N(SocketType, Socket, RequestStr, Options, TimeOut, Node, Port, + #state{}, N-1) + end. + request(#state{mfa = {Module, Function, Args}, request = RequestStr, socket = Socket} = State, TimeOut) -> @@ -160,13 +201,35 @@ request(#state{mfa = {Module, Function, Args}, {ssl_closed, Socket} -> exit({test_failed, connection_closed}); {ssl_error, Socket, Reason} -> - ct:fail({ssl_error, Reason}) + ct:fail({ssl_error, Reason}); + {Socket, {data, Data}} when is_port(Socket) -> + case Module:Function([list_to_binary(Data) | Args]) of + {ok, Parsed} -> + port_handle_http_msg(Parsed, State); + {_, whole_body, _} when HeadRequest =:= "HEAD" -> + State#state{body = <<>>}; + NewMFA -> + request(State#state{mfa = NewMFA}, TimeOut) + end; + {Socket, closed} when Function =:= whole_body -> + State#state{body = hd(Args)}; + {Socket, closed} -> + exit({test_failed, connection_closed}) after TimeOut -> ct:pal("~p ~w[~w]request -> timeout" - "~n", [self(), ?MODULE, ?LINE]), + "~p~n", [self(), ?MODULE, ?LINE, Args]), ct:fail(connection_timed_out) end. + +port_handle_http_msg({Version, StatusCode, ReasonPharse, Headers, Body}, State) -> + State#state{status_line = {Version, + StatusCode, + ReasonPharse}, + headers = Headers, + body = Body}. + + handle_http_msg({Version, StatusCode, ReasonPharse, Headers, Body}, State = #state{request = RequestStr}) -> case is_expect(RequestStr) of diff --git a/lib/inets/test/inets.spec b/lib/inets/test/inets.spec index ed102f8219..6cb3d6526c 100644 --- a/lib/inets/test/inets.spec +++ b/lib/inets/test/inets.spec @@ -1 +1,3 @@ -{suites,"../inets_test",all}. +{suites,"../inets_test", all}. +{skip_suites, "../inets_test", [httpd_bench_SUITE], + "Benchmarks run separately"}. diff --git a/lib/inets/test/inets_bench.spec b/lib/inets/test/inets_bench.spec new file mode 100644 index 0000000000..19136e691b --- /dev/null +++ b/lib/inets/test/inets_bench.spec @@ -0,0 +1 @@ +{suites,"../inets_test",[httpd_bench_SUITE]}. diff --git a/lib/inets/test/inets_test_lib.erl b/lib/inets/test/inets_test_lib.erl index f1185f7574..2529cc5f9b 100644 --- a/lib/inets/test/inets_test_lib.erl +++ b/lib/inets/test/inets_test_lib.erl @@ -463,8 +463,9 @@ connect_bin(essl, Host, Port, Opts0) -> connect(ssl, Host, Port, Opts); connect_bin(ip_comm, Host, Port, Opts0) -> Opts = [binary, {packet, 0} | Opts0], - connect(ip_comm, Host, Port, Opts). - + connect(ip_comm, Host, Port, Opts); +connect_bin(Type, Host, Port, Opts) -> + connect(Type, Host, Port, Opts). connect_byte(SockType, Host, Port) -> connect_byte(SockType, Host, Port, []). @@ -477,27 +478,40 @@ connect_byte(essl, Host, Port, Opts0) -> connect(ssl, Host, Port, Opts); connect_byte(ip_comm, Host, Port, Opts0) -> Opts = [{packet,0} | Opts0], - connect(ip_comm, Host, Port, Opts). + connect(ip_comm, Host, Port, Opts); +connect_byte(Type, Host, Port, Opts) -> + connect(Type, Host, Port, Opts). connect(ip_comm, Host, Port, Opts) -> gen_tcp:connect(Host, Port, Opts); connect(ssl, Host, Port, Opts) -> - ssl:connect(Host, Port, Opts). + ssl:connect(Host, Port, Opts); +connect(openssl_port, Host, Port, Opts) -> + CaCertFile = proplists:get_value(cacertfile, Opts), + Cmd = "openssl s_client -quiet -port " ++ integer_to_list(Port) ++ " -host " ++ Host + ++ " -CAfile " ++ CaCertFile, + ct:log("openssl cmd: ~p~n", [Cmd]), + OpensslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), + read_junk(OpensslPort), + {ok, OpensslPort}. send(ssl, Socket, Data) -> ssl:send(Socket, Data); send(essl, Socket, Data) -> ssl:send(Socket, Data); send(ip_comm,Socket,Data) -> - gen_tcp:send(Socket,Data). - - + gen_tcp:send(Socket,Data); +send(openssl_port, Port, Data) -> + true = port_command(Port, Data), + ok. close(ssl,Socket) -> catch ssl:close(Socket); close(essl,Socket) -> catch ssl:close(Socket); close(ip_comm,Socket) -> - catch gen_tcp:close(Socket). + catch gen_tcp:close(Socket); +close(openssl_port, Port) -> + exit(Port, normal). hours(N) -> trunc(N * 1000 * 60 * 60). @@ -572,3 +586,11 @@ do_inet_port(Node) -> {ok, Socket} = rpc:call(Node, gen_tcp, listen, [0, [{reuseaddr, true}]]), {ok, Port} = rpc:call(Node, inet, port, [Socket]), {Port, Socket}. + +read_junk(OpensslPort) -> + receive + {OpensslPort, _} -> + read_junk(OpensslPort) + after 500 -> + ok + end. diff --git a/lib/inets/test/make_certs.erl b/lib/inets/test/make_certs.erl new file mode 100644 index 0000000000..7215a59823 --- /dev/null +++ b/lib/inets/test/make_certs.erl @@ -0,0 +1,530 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2007-2015. 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(make_certs). +-compile([export_all]). + +%-export([all/1, all/2, rootCA/2, intermediateCA/3, endusers/3, enduser/3, revoke/3, gencrl/2, verify/3]). + +-record(config, {commonName, + organizationalUnitName = "Erlang OTP", + organizationName = "Ericsson AB", + localityName = "Stockholm", + countryName = "SE", + emailAddress = "[email protected]", + default_bits = 2048, + v2_crls = true, + ecc_certs = false, + issuing_distribution_point = false, + crl_port = 8000, + openssl_cmd = "openssl"}). + + +default_config() -> + #config{}. + +make_config(Args) -> + make_config(Args, #config{}). + +make_config([], C) -> + C; +make_config([{organizationalUnitName, Name}|T], C) when is_list(Name) -> + make_config(T, C#config{organizationalUnitName = Name}); +make_config([{organizationName, Name}|T], C) when is_list(Name) -> + make_config(T, C#config{organizationName = Name}); +make_config([{localityName, Name}|T], C) when is_list(Name) -> + make_config(T, C#config{localityName = Name}); +make_config([{countryName, Name}|T], C) when is_list(Name) -> + make_config(T, C#config{countryName = Name}); +make_config([{emailAddress, Name}|T], C) when is_list(Name) -> + make_config(T, C#config{emailAddress = Name}); +make_config([{default_bits, Bits}|T], C) when is_integer(Bits) -> + make_config(T, C#config{default_bits = Bits}); +make_config([{v2_crls, Bool}|T], C) when is_boolean(Bool) -> + make_config(T, C#config{v2_crls = Bool}); +make_config([{crl_port, Port}|T], C) when is_integer(Port) -> + make_config(T, C#config{crl_port = Port}); +make_config([{ecc_certs, Bool}|T], C) when is_boolean(Bool) -> + make_config(T, C#config{ecc_certs = Bool}); +make_config([{issuing_distribution_point, Bool}|T], C) when is_boolean(Bool) -> + make_config(T, C#config{issuing_distribution_point = Bool}); +make_config([{openssl_cmd, Cmd}|T], C) when is_list(Cmd) -> + make_config(T, C#config{openssl_cmd = Cmd}). + + +all([DataDir, PrivDir]) -> + all(DataDir, PrivDir). + +all(DataDir, PrivDir) -> + all(DataDir, PrivDir, #config{}). + +all(DataDir, PrivDir, C) when is_list(C) -> + all(DataDir, PrivDir, make_config(C)); +all(DataDir, PrivDir, C = #config{}) -> + ok = filelib:ensure_dir(filename:join(PrivDir, "erlangCA")), + create_rnd(DataDir, PrivDir), % For all requests + rootCA(PrivDir, "erlangCA", C), + intermediateCA(PrivDir, "otpCA", "erlangCA", C), + endusers(PrivDir, "otpCA", ["client", "server", "revoked", "a.server", "b.server"], C), + endusers(PrivDir, "erlangCA", ["localhost"], C), + %% Create keycert files + SDir = filename:join([PrivDir, "server"]), + SC = filename:join([SDir, "cert.pem"]), + SK = filename:join([SDir, "key.pem"]), + SKC = filename:join([SDir, "keycert.pem"]), + append_files([SK, SC], SKC), + CDir = filename:join([PrivDir, "client"]), + CC = filename:join([CDir, "cert.pem"]), + CK = filename:join([CDir, "key.pem"]), + CKC = filename:join([CDir, "keycert.pem"]), + append_files([CK, CC], CKC), + RDir = filename:join([PrivDir, "revoked"]), + RC = filename:join([RDir, "cert.pem"]), + RK = filename:join([RDir, "key.pem"]), + RKC = filename:join([RDir, "keycert.pem"]), + revoke(PrivDir, "otpCA", "revoked", C), + append_files([RK, RC], RKC), + remove_rnd(PrivDir), + {ok, C}. + +append_files(FileNames, ResultFileName) -> + {ok, ResultFile} = file:open(ResultFileName, [write]), + do_append_files(FileNames, ResultFile). + +do_append_files([], RF) -> + ok = file:close(RF); +do_append_files([F|Fs], RF) -> + {ok, Data} = file:read_file(F), + ok = file:write(RF, Data), + do_append_files(Fs, RF). + +rootCA(Root, Name, C) -> + create_ca_dir(Root, Name, ca_cnf(C#config{commonName = Name})), + create_self_signed_cert(Root, Name, req_cnf(C#config{commonName = Name}), C), + file:copy(filename:join([Root, Name, "cert.pem"]), filename:join([Root, Name, "cacerts.pem"])), + gencrl(Root, Name, C). + +intermediateCA(Root, CA, ParentCA, C) -> + create_ca_dir(Root, CA, ca_cnf(C#config{commonName = CA})), + CARoot = filename:join([Root, CA]), + CnfFile = filename:join([CARoot, "req.cnf"]), + file:write_file(CnfFile, req_cnf(C#config{commonName = CA})), + KeyFile = filename:join([CARoot, "private", "key.pem"]), + ReqFile = filename:join([CARoot, "req.pem"]), + create_req(Root, CnfFile, KeyFile, ReqFile, C), + CertFile = filename:join([CARoot, "cert.pem"]), + sign_req(Root, ParentCA, "ca_cert", ReqFile, CertFile, C), + CACertsFile = filename:join(CARoot, "cacerts.pem"), + file:copy(filename:join([Root, ParentCA, "cacerts.pem"]), CACertsFile), + %% append this CA's cert to the cacerts file + {ok, Bin} = file:read_file(CertFile), + {ok, FD} = file:open(CACertsFile, [append]), + file:write(FD, ["\n", Bin]), + file:close(FD), + gencrl(Root, CA, C). + +endusers(Root, CA, Users, C) -> + [enduser(Root, CA, User, C) || User <- Users]. + +enduser(Root, CA, User, C) -> + UsrRoot = filename:join([Root, User]), + file:make_dir(UsrRoot), + CnfFile = filename:join([UsrRoot, "req.cnf"]), + file:write_file(CnfFile, req_cnf(C#config{commonName = User})), + KeyFile = filename:join([UsrRoot, "key.pem"]), + ReqFile = filename:join([UsrRoot, "req.pem"]), + create_req(Root, CnfFile, KeyFile, ReqFile, C), + %create_req(Root, CnfFile, KeyFile, ReqFile), + CertFileAllUsage = filename:join([UsrRoot, "cert.pem"]), + sign_req(Root, CA, "user_cert", ReqFile, CertFileAllUsage, C), + CertFileDigitalSigOnly = filename:join([UsrRoot, "digital_signature_only_cert.pem"]), + sign_req(Root, CA, "user_cert_digital_signature_only", ReqFile, CertFileDigitalSigOnly, C), + CACertsFile = filename:join(UsrRoot, "cacerts.pem"), + file:copy(filename:join([Root, CA, "cacerts.pem"]), CACertsFile), + ok. + +revoke(Root, CA, User, C) -> + UsrCert = filename:join([Root, User, "cert.pem"]), + CACnfFile = filename:join([Root, CA, "ca.cnf"]), + Cmd = [C#config.openssl_cmd, " ca" + " -revoke ", UsrCert, + [" -crl_reason keyCompromise" || C#config.v2_crls ], + " -config ", CACnfFile], + Env = [{"ROOTDIR", filename:absname(Root)}], + cmd(Cmd, Env), + gencrl(Root, CA, C). + +gencrl(Root, CA, C) -> + CACnfFile = filename:join([Root, CA, "ca.cnf"]), + CACRLFile = filename:join([Root, CA, "crl.pem"]), + Cmd = [C#config.openssl_cmd, " ca" + " -gencrl ", + " -crlhours 24", + " -out ", CACRLFile, + " -config ", CACnfFile], + Env = [{"ROOTDIR", filename:absname(Root)}], + cmd(Cmd, Env). + +verify(Root, CA, User, C) -> + CAFile = filename:join([Root, User, "cacerts.pem"]), + CACRLFile = filename:join([Root, CA, "crl.pem"]), + CertFile = filename:join([Root, User, "cert.pem"]), + Cmd = [C#config.openssl_cmd, " verify" + " -CAfile ", CAFile, + " -CRLfile ", CACRLFile, %% this is undocumented, but seems to work + " -crl_check ", + CertFile], + Env = [{"ROOTDIR", filename:absname(Root)}], + try cmd(Cmd, Env) catch + exit:{eval_cmd, _, _} -> + invalid + end. + +create_self_signed_cert(Root, CAName, Cnf, C = #config{ecc_certs = true}) -> + CARoot = filename:join([Root, CAName]), + CnfFile = filename:join([CARoot, "req.cnf"]), + file:write_file(CnfFile, Cnf), + KeyFile = filename:join([CARoot, "private", "key.pem"]), + CertFile = filename:join([CARoot, "cert.pem"]), + Cmd = [C#config.openssl_cmd, " ecparam" + " -out ", KeyFile, + " -name secp521r1 ", + %" -name sect283k1 ", + " -genkey "], + Env = [{"ROOTDIR", filename:absname(Root)}], + cmd(Cmd, Env), + + Cmd2 = [C#config.openssl_cmd, " req" + " -new" + " -x509" + " -config ", CnfFile, + " -key ", KeyFile, + " -outform PEM ", + " -out ", CertFile], + cmd(Cmd2, Env); +create_self_signed_cert(Root, CAName, Cnf, C) -> + CARoot = filename:join([Root, CAName]), + CnfFile = filename:join([CARoot, "req.cnf"]), + file:write_file(CnfFile, Cnf), + KeyFile = filename:join([CARoot, "private", "key.pem"]), + CertFile = filename:join([CARoot, "cert.pem"]), + Cmd = [C#config.openssl_cmd, " req" + " -new" + " -x509" + " -config ", CnfFile, + " -keyout ", KeyFile, + " -outform PEM", + " -out ", CertFile], + Env = [{"ROOTDIR", filename:absname(Root)}], + cmd(Cmd, Env). + + +create_ca_dir(Root, CAName, Cnf) -> + CARoot = filename:join([Root, CAName]), + ok = filelib:ensure_dir(CARoot), + file:make_dir(CARoot), + create_dirs(CARoot, ["certs", "crl", "newcerts", "private"]), + create_rnd(Root, filename:join([CAName, "private"])), + create_files(CARoot, [{"serial", "01\n"}, + {"crlnumber", "01"}, + {"index.txt", ""}, + {"ca.cnf", Cnf}]). + +create_req(Root, CnfFile, KeyFile, ReqFile, C = #config{ecc_certs = true}) -> + Cmd = [C#config.openssl_cmd, " ecparam" + " -out ", KeyFile, + " -name secp521r1 ", + %" -name sect283k1 ", + " -genkey "], + Env = [{"ROOTDIR", filename:absname(Root)}], + cmd(Cmd, Env), + Cmd2 = [C#config.openssl_cmd, " req" + " -new ", + " -key ", KeyFile, + " -outform PEM ", + " -out ", ReqFile, + " -config ", CnfFile], + cmd(Cmd2, Env); + %fix_key_file(KeyFile). +create_req(Root, CnfFile, KeyFile, ReqFile, C) -> + Cmd = [C#config.openssl_cmd, " req" + " -new" + " -config ", CnfFile, + " -outform PEM ", + " -keyout ", KeyFile, + " -out ", ReqFile], + Env = [{"ROOTDIR", filename:absname(Root)}], + cmd(Cmd, Env). + %fix_key_file(KeyFile). + + +sign_req(Root, CA, CertType, ReqFile, CertFile, C) -> + CACnfFile = filename:join([Root, CA, "ca.cnf"]), + Cmd = [C#config.openssl_cmd, " ca" + " -batch" + " -notext" + " -config ", CACnfFile, + " -extensions ", CertType, + " -in ", ReqFile, + " -out ", CertFile], + Env = [{"ROOTDIR", filename:absname(Root)}], + cmd(Cmd, Env). + +%% +%% Misc +%% + +create_dirs(Root, Dirs) -> + lists:foreach(fun(Dir) -> + file:make_dir(filename:join([Root, Dir])) end, + Dirs). + +create_files(Root, NameContents) -> + lists:foreach( + fun({Name, Contents}) -> + file:write_file(filename:join([Root, Name]), Contents) end, + NameContents). + +create_rnd(FromDir, ToDir) -> + From = filename:join([FromDir, "RAND"]), + To = filename:join([ToDir, "RAND"]), + file:copy(From, To). + +remove_rnd(Dir) -> + File = filename:join([Dir, "RAND"]), + file:delete(File). + +cmd(Cmd, Env) -> + FCmd = lists:flatten(Cmd), + Port = open_port({spawn, FCmd}, [stream, eof, exit_status, stderr_to_stdout, + {env, Env}]), + eval_cmd(Port, FCmd). + +eval_cmd(Port, Cmd) -> + receive + {Port, {data, _}} -> + eval_cmd(Port, Cmd); + {Port, eof} -> + ok + end, + receive + {Port, {exit_status, 0}} -> + ok; + {Port, {exit_status, Status}} -> + exit({eval_cmd, Cmd, Status}) + after 0 -> + ok + end. + +%% +%% Contents of configuration files +%% + +req_cnf(C) -> + ["# Purpose: Configuration for requests (end users and CAs)." + "\n" + "ROOTDIR = $ENV::ROOTDIR\n" + "\n" + + "[req]\n" + "input_password = secret\n" + "output_password = secret\n" + "default_bits = ", integer_to_list(C#config.default_bits), "\n" + "RANDFILE = $ROOTDIR/RAND\n" + "encrypt_key = no\n" + "default_md = md5\n" + "#string_mask = pkix\n" + "x509_extensions = ca_ext\n" + "prompt = no\n" + "distinguished_name= name\n" + "\n" + + "[name]\n" + "commonName = ", C#config.commonName, "\n" + "organizationalUnitName = ", C#config.organizationalUnitName, "\n" + "organizationName = ", C#config.organizationName, "\n" + "localityName = ", C#config.localityName, "\n" + "countryName = ", C#config.countryName, "\n" + "emailAddress = ", C#config.emailAddress, "\n" + "\n" + + "[ca_ext]\n" + "basicConstraints = critical, CA:true\n" + "keyUsage = cRLSign, keyCertSign\n" + "subjectKeyIdentifier = hash\n" + "subjectAltName = email:copy\n"]. + +ca_cnf(C = #config{issuing_distribution_point = true}) -> + ["# Purpose: Configuration for CAs.\n" + "\n" + "ROOTDIR = $ENV::ROOTDIR\n" + "default_ca = ca\n" + "\n" + + "[ca]\n" + "dir = $ROOTDIR/", C#config.commonName, "\n" + "certs = $dir/certs\n" + "crl_dir = $dir/crl\n" + "database = $dir/index.txt\n" + "new_certs_dir = $dir/newcerts\n" + "certificate = $dir/cert.pem\n" + "serial = $dir/serial\n" + "crl = $dir/crl.pem\n", + ["crlnumber = $dir/crlnumber\n" || C#config.v2_crls], + "private_key = $dir/private/key.pem\n" + "RANDFILE = $dir/private/RAND\n" + "\n" + "x509_extensions = user_cert\n", + ["crl_extensions = crl_ext\n" || C#config.v2_crls], + "unique_subject = no\n" + "default_days = 3600\n" + "default_md = md5\n" + "preserve = no\n" + "policy = policy_match\n" + "\n" + + "[policy_match]\n" + "commonName = supplied\n" + "organizationalUnitName = optional\n" + "organizationName = match\n" + "countryName = match\n" + "localityName = match\n" + "emailAddress = supplied\n" + "\n" + + "[crl_ext]\n" + "authorityKeyIdentifier=keyid:always,issuer:always\n", + ["issuingDistributionPoint=critical, @idpsec\n" || C#config.issuing_distribution_point], + + "[idpsec]\n" + "fullname=URI:http://localhost:8000/",C#config.commonName,"/crl.pem\n" + + "[user_cert]\n" + "basicConstraints = CA:false\n" + "keyUsage = nonRepudiation, digitalSignature, keyEncipherment\n" + "subjectKeyIdentifier = hash\n" + "authorityKeyIdentifier = keyid,issuer:always\n" + "subjectAltName = email:copy\n" + "issuerAltName = issuer:copy\n" + "crlDistributionPoints=@crl_section\n" + + "[crl_section]\n" + %% intentionally invalid + "URI.1=http://localhost/",C#config.commonName,"/crl.pem\n" + "URI.2=http://localhost:",integer_to_list(C#config.crl_port),"/",C#config.commonName,"/crl.pem\n" + "\n" + + "[user_cert_digital_signature_only]\n" + "basicConstraints = CA:false\n" + "keyUsage = digitalSignature\n" + "subjectKeyIdentifier = hash\n" + "authorityKeyIdentifier = keyid,issuer:always\n" + "subjectAltName = email:copy\n" + "issuerAltName = issuer:copy\n" + "\n" + + "[ca_cert]\n" + "basicConstraints = critical,CA:true\n" + "keyUsage = cRLSign, keyCertSign\n" + "subjectKeyIdentifier = hash\n" + "authorityKeyIdentifier = keyid:always,issuer:always\n" + "subjectAltName = email:copy\n" + "issuerAltName = issuer:copy\n" + "crlDistributionPoints=@crl_section\n" + ]; + +ca_cnf(C = #config{issuing_distribution_point = false}) -> + ["# Purpose: Configuration for CAs.\n" + "\n" + "ROOTDIR = $ENV::ROOTDIR\n" + "default_ca = ca\n" + "\n" + + "[ca]\n" + "dir = $ROOTDIR/", C#config.commonName, "\n" + "certs = $dir/certs\n" + "crl_dir = $dir/crl\n" + "database = $dir/index.txt\n" + "new_certs_dir = $dir/newcerts\n" + "certificate = $dir/cert.pem\n" + "serial = $dir/serial\n" + "crl = $dir/crl.pem\n", + ["crlnumber = $dir/crlnumber\n" || C#config.v2_crls], + "private_key = $dir/private/key.pem\n" + "RANDFILE = $dir/private/RAND\n" + "\n" + "x509_extensions = user_cert\n", + ["crl_extensions = crl_ext\n" || C#config.v2_crls], + "unique_subject = no\n" + "default_days = 3600\n" + "default_md = md5\n" + "preserve = no\n" + "policy = policy_match\n" + "\n" + + "[policy_match]\n" + "commonName = supplied\n" + "organizationalUnitName = optional\n" + "organizationName = match\n" + "countryName = match\n" + "localityName = match\n" + "emailAddress = supplied\n" + "\n" + + "[crl_ext]\n" + "authorityKeyIdentifier=keyid:always,issuer:always\n", + %["issuingDistributionPoint=critical, @idpsec\n" || C#config.issuing_distribution_point], + + %"[idpsec]\n" + %"fullname=URI:http://localhost:8000/",C#config.commonName,"/crl.pem\n" + + "[user_cert]\n" + "basicConstraints = CA:false\n" + "keyUsage = nonRepudiation, digitalSignature, keyEncipherment\n" + "subjectKeyIdentifier = hash\n" + "authorityKeyIdentifier = keyid,issuer:always\n" + "subjectAltName = email:copy\n" + "issuerAltName = issuer:copy\n" + %"crlDistributionPoints=@crl_section\n" + + %%"[crl_section]\n" + %% intentionally invalid + %%"URI.1=http://localhost/",C#config.commonName,"/crl.pem\n" + %%"URI.2=http://localhost:",integer_to_list(C#config.crl_port),"/",C#config.commonName,"/crl.pem\n" + %%"\n" + + "[user_cert_digital_signature_only]\n" + "basicConstraints = CA:false\n" + "keyUsage = digitalSignature\n" + "subjectKeyIdentifier = hash\n" + "authorityKeyIdentifier = keyid,issuer:always\n" + "subjectAltName = email:copy\n" + "issuerAltName = issuer:copy\n" + "\n" + + "[ca_cert]\n" + "basicConstraints = critical,CA:true\n" + "keyUsage = cRLSign, keyCertSign\n" + "subjectKeyIdentifier = hash\n" + "authorityKeyIdentifier = keyid:always,issuer:always\n" + "subjectAltName = email:copy\n" + "issuerAltName = issuer:copy\n" + %"crlDistributionPoints=@crl_section\n" + ]. diff --git a/lib/inets/test/old_httpd_SUITE.erl b/lib/inets/test/old_httpd_SUITE.erl deleted file mode 100644 index 172db53844..0000000000 --- a/lib/inets/test/old_httpd_SUITE.erl +++ /dev/null @@ -1,2347 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2005-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(old_httpd_SUITE). - --include_lib("common_test/include/ct.hrl"). --include("inets_test_lib.hrl"). - --include_lib("kernel/include/file.hrl"). - -%% Test server specific exports --export([all/0, suite/0,groups/0,init_per_group/2,end_per_group/2]). --export([init_per_testcase/2, end_per_testcase/2, - init_per_suite/1, end_per_suite/1]). - -%% Core Server tests --export([ - ip_mod_alias/1, - ip_mod_actions/1, - ip_mod_security/1, - ip_mod_auth/1, - ip_mod_auth_api/1, - ip_mod_auth_mnesia_api/1, - ip_mod_htaccess/1, - ip_mod_cgi/1, - ip_mod_esi/1, - ip_mod_get/1, - ip_mod_head/1, - ip_mod_all/1, - ip_load_light/1, - ip_load_medium/1, - ip_load_heavy/1, - ip_dos_hostname/1, - ip_time_test/1, - ip_block_disturbing_idle/1, - ip_block_non_disturbing_idle/1, - ip_block_503/1, - ip_block_disturbing_active/1, - ip_block_non_disturbing_active/1, - ip_block_disturbing_active_timeout_not_released/1, - ip_block_disturbing_active_timeout_released/1, - ip_block_non_disturbing_active_timeout_not_released/1, - ip_block_non_disturbing_active_timeout_released/1, - ip_block_disturbing_blocker_dies/1, - ip_block_non_disturbing_blocker_dies/1, - ip_restart_no_block/1, - ip_restart_disturbing_block/1, - ip_restart_non_disturbing_block/1 - ]). - --export([ - essl_mod_alias/1, - essl_mod_actions/1, - essl_mod_security/1, - essl_mod_auth/1, - essl_mod_auth_api/1, - essl_mod_auth_mnesia_api/1, - essl_mod_htaccess/1, - essl_mod_cgi/1, - essl_mod_esi/1, - essl_mod_get/1, - essl_mod_head/1, - essl_mod_all/1, - essl_load_light/1, - essl_load_medium/1, - essl_load_heavy/1, - essl_dos_hostname/1, - essl_time_test/1, - essl_restart_no_block/1, - essl_restart_disturbing_block/1, - essl_restart_non_disturbing_block/1, - essl_block_disturbing_idle/1, - essl_block_non_disturbing_idle/1, - essl_block_503/1, - essl_block_disturbing_active/1, - essl_block_non_disturbing_active/1, - essl_block_disturbing_active_timeout_not_released/1, - essl_block_disturbing_active_timeout_released/1, - essl_block_non_disturbing_active_timeout_not_released/1, - essl_block_non_disturbing_active_timeout_released/1, - essl_block_disturbing_blocker_dies/1, - essl_block_non_disturbing_blocker_dies/1 - ]). - -%%% HTTP 1.1 tests --export([ip_host/1, ip_chunked/1, ip_expect/1, ip_range/1, - ip_if_test/1, ip_http_trace/1, ip_http1_1_head/1, - ip_mod_cgi_chunked_encoding_test/1]). - -%%% HTTP 1.0 tests --export([ip_head_1_0/1, ip_get_1_0/1, ip_post_1_0/1]). - -%%% HTTP 0.9 tests --export([ip_get_0_9/1]). - -%%% Ticket tests --export([ticket_5775/1,ticket_5865/1,ticket_5913/1,ticket_6003/1, - ticket_7304/1]). - -%%% IPv6 tests --export([ipv6_hostname_ipcomm/0, ipv6_hostname_ipcomm/1, - ipv6_address_ipcomm/0, ipv6_address_ipcomm/1, - ipv6_hostname_essl/0, ipv6_hostname_essl/1, - ipv6_address_essl/0, ipv6_address_essl/1]). - -%% Help functions --export([cleanup_mnesia/0, setup_mnesia/0, setup_mnesia/1]). - --define(IP_PORT, 8898). --define(SSL_PORT, 8899). --define(MAX_HEADER_SIZE, 256). --define(IPV6_LOCAL_HOST, "0:0:0:0:0:0:0:1"). - -%% Minutes before failed auths timeout. --define(FAIL_EXPIRE_TIME,1). - -%% Seconds before successful auths timeout. --define(AUTH_TIMEOUT,5). - --record(httpd_user, {user_name, password, user_data}). --record(httpd_group, {group_name, userlist}). - - -%%-------------------------------------------------------------------- -%% all(Arg) -> [Doc] | [Case] | {skip, Comment} -%% Arg - doc | suite -%% Doc - string() -%% Case - atom() -%% Name of a test case function. -%% Comment - string() -%% Description: Returns documentation/test cases in this test suite -%% or a skip tuple if the platform is not supported. -%%-------------------------------------------------------------------- -suite() -> [{ct_hooks,[ts_install_cth]}]. - -all() -> - [ - {group, ip}, - {group, ssl}, - %%{group, http_1_1_ip}, - %%{group, http_1_0_ip}, - %%{group, http_0_9_ip}, - %%{group, ipv6}, - {group, tickets} - ]. - -groups() -> - [ - {ip, [], - [ - %%ip_mod_alias, - ip_mod_actions, - %%ip_mod_security, - %% ip_mod_auth, - %% ip_mod_auth_api, - ip_mod_auth_mnesia_api, - %%ip_mod_htaccess, - %%ip_mod_cgi, - %%ip_mod_esi, - %%ip_mod_get, - %%ip_mod_head, - %%ip_mod_all, - %% ip_load_light, - %% ip_load_medium, - %% ip_load_heavy, - %%ip_dos_hostname, - ip_time_test, - %% Only used through load_config - %% but we still need these tests - %% should be cleaned up and moved to new test suite - %%ip_restart_no_block, - %%ip_restart_disturbing_block, - %%ip_restart_non_disturbing_block, - %% Tested in inets_SUITE - %%ip_block_disturbing_idle, - %%ip_block_non_disturbing_idle, - ip_block_503 - %% Tested in new httpd_SUITE - %%ip_block_disturbing_active, - %%ip_block_non_disturbing_active, - %%ip_block_disturbing_blocker_dies, - %%ip_block_non_disturbing_blocker_dies - %% No longer relevant - %%ip_block_disturbing_active_timeout_not_released, - %%ip_block_disturbing_active_timeout_released, - %%ip_block_non_disturbing_active_timeout_not_released, - %%ip_block_non_disturbing_active_timeout_released, - ]}, - {ssl, [], [{group, essl}]}, - {essl, [], - [ - %%essl_mod_alias, - essl_mod_actions, - %% essl_mod_security, - %% essl_mod_auth, - %% essl_mod_auth_api, - essl_mod_auth_mnesia_api, - %%essl_mod_htaccess, - %%essl_mod_cgi, - %%essl_mod_esi, - %%essl_mod_get, - %%essl_mod_head, - %% essl_mod_all, - %% essl_load_light, - %% essl_load_medium, - %% essl_load_heavy, - %%essl_dos_hostname, - essl_time_test - %% Replaced by load_config - %% essl_restart_no_block, - %% essl_restart_disturbing_block, - %% essl_restart_non_disturbing_block, - %% essl_block_disturbing_idle, - %% essl_block_non_disturbing_idle, essl_block_503, - %% essl_block_disturbing_active, - %% essl_block_non_disturbing_active, - %% essl_block_disturbing_active_timeout_not_released, - %% essl_block_disturbing_active_timeout_released, - %% essl_block_non_disturbing_active_timeout_not_released, - %% essl_block_non_disturbing_active_timeout_released, - %% essl_block_disturbing_blocker_dies, - %% essl_block_non_disturbing_blocker_dies - ]}, - %% {http_1_1_ip, [], - %% [ - %% %%ip_host, ip_chunked, ip_expect, - %% %%ip_range, - %% %%ip_if_test - %% %%ip_http_trace, ip_http1_1_head, - %% %%ip_mod_cgi_chunked_encoding_test - %% ]}, - %%{http_1_0_ip, [], - %%[ip_head_1_0, ip_get_1_0, ip_post_1_0]}, - %%{http_0_9_ip, [], [ip_get_0_9]}, - %% {ipv6, [], [ipv6_hostname_ipcomm, ipv6_address_ipcomm, - %% ipv6_hostname_essl, ipv6_address_essl]}, - {tickets, [], - [%%ticket_5775, ticket_5865, - ticket_5913%%, ticket_6003, - %%ticket_7304 - ]}]. - -init_per_group(ipv6 = _GroupName, Config) -> - case inets_test_lib:has_ipv6_support() of - {ok, _} -> - Config; - _ -> - {skip, "Host does not support IPv6"} - end; -init_per_group(_GroupName, Config) -> - Config. - -end_per_group(_GroupName, Config) -> - Config. - - -%%-------------------------------------------------------------------- -%% Function: init_per_suite(Config) -> Config -%% Config - [tuple()] -%% A list of key/value pairs, holding the test case configuration. -%% Description: Initiation before the whole suite -%% -%% Note: This function is free to add any key/value pairs to the Config -%% variable, but should NOT alter/remove any existing entries. -%%-------------------------------------------------------------------- -init_per_suite(Config) -> - io:format(user, "init_per_suite -> entry with" - "~n Config: ~p" - "~n", [Config]), - - PrivDir = proplists:get_value(priv_dir, Config), - SuiteTopDir = filename:join(PrivDir, ?MODULE), - case file:make_dir(SuiteTopDir) of - ok -> - ok; - {error, eexist} -> - ok; - Error -> - throw({error, {failed_creating_suite_top_dir, Error}}) - end, - - [{has_ipv6_support, inets_test_lib:has_ipv6_support()}, - {suite_top_dir, SuiteTopDir}, - {node, node()}, - {host, inets_test_lib:hostname()}, - {address, getaddr()} | Config]. - - -%%-------------------------------------------------------------------- -%% Function: end_per_suite(Config) -> _ -%% Config - [tuple()] -%% A list of key/value pairs, holding the test case configuration. -%% Description: Cleanup after the whole suite -%%-------------------------------------------------------------------- - -end_per_suite(_Config) -> - %% SuiteTopDir = proplists:get_value(suite_top_dir, Config), - %% inets_test_lib:del_dirs(SuiteTopDir), - ok. - - -%%-------------------------------------------------------------------- -%% Function: init_per_testcase(Case, Config) -> Config -%% Case - atom() -%% Name of the test case that is about to be run. -%% Config - [tuple()] -%% A list of key/value pairs, holding the test case configuration. -%% -%% Description: Initiation before each test case -%% -%% Note: This function is free to add any key/value pairs to the Config -%% variable, but should NOT alter/remove any existing entries. -%%-------------------------------------------------------------------- -init_per_testcase(Case, Config) -> - NewConfig = init_per_testcase2(Case, Config), - init_per_testcase3(Case, NewConfig). - - -init_per_testcase2(Case, Config) -> - - %% tsp("init_per_testcase2 -> entry with" - %% "~n Config: ~p", [Config]), - - IpNormal = integer_to_list(?IP_PORT) ++ ".conf", - IpHtaccess = integer_to_list(?IP_PORT) ++ "htaccess.conf", - SslNormal = integer_to_list(?SSL_PORT) ++ ".conf", - SslHtaccess = integer_to_list(?SSL_PORT) ++ "htaccess.conf", - - DataDir = proplists:get_value(data_dir, Config), - SuiteTopDir = proplists:get_value(suite_top_dir, Config), - - %% tsp("init_per_testcase2 -> " - %% "~n SuiteDir: ~p" - %% "~n DataDir: ~p", [SuiteTopDir, DataDir]), - - TcTopDir = filename:join(SuiteTopDir, Case), - ?line ok = file:make_dir(TcTopDir), - - %% tsp("init_per_testcase2 -> " - %% "~n TcTopDir: ~p", [TcTopDir]), - - DataSrc = filename:join([DataDir, "server_root"]), - ServerRoot = filename:join([TcTopDir, "server_root"]), - - %% tsp("init_per_testcase2 -> " - %% "~n DataSrc: ~p" - %% "~n ServerRoot: ~p", [DataSrc, ServerRoot]), - - ok = file:make_dir(ServerRoot), - ok = file:make_dir(filename:join([TcTopDir, "logs"])), - - NewConfig = [{tc_top_dir, TcTopDir}, {server_root, ServerRoot} | Config], - - %% tsp("init_per_testcase2 -> copy DataSrc to ServerRoot"), - - inets_test_lib:copy_dirs(DataSrc, ServerRoot), - - %% tsp("init_per_testcase2 -> fix cgi"), - EnvCGI = filename:join([ServerRoot, "cgi-bin", "printenv.sh"]), - {ok, FileInfo} = file:read_file_info(EnvCGI), - ok = file:write_file_info(EnvCGI, - FileInfo#file_info{mode = 8#00755}), - - EchoCGI = case test_server:os_type() of - {win32, _} -> - "cgi_echo.exe"; - _ -> - "cgi_echo" - end, - CGIDir = filename:join([ServerRoot, "cgi-bin"]), - inets_test_lib:copy_file(EchoCGI, DataDir, CGIDir), - NewEchoCGI = filename:join([CGIDir, EchoCGI]), - {ok, FileInfo1} = file:read_file_info(NewEchoCGI), - ok = file:write_file_info(NewEchoCGI, - FileInfo1#file_info{mode = 8#00755}), - - %% To be used by IP test cases - %% tsp("init_per_testcase2 -> ip testcase setups"), - create_config([{port, ?IP_PORT}, {sock_type, ip_comm} | NewConfig], - normal_access, IpNormal), - create_config([{port, ?IP_PORT}, {sock_type, ip_comm} | NewConfig], - mod_htaccess, IpHtaccess), - - %% To be used by SSL test cases - %% tsp("init_per_testcase2 -> ssl testcase setups"), - SocketType = - case atom_to_list(Case) of - [X, $s, $s, $l | _] -> - case X of - $p -> ssl; - $e -> essl - end; - _ -> - ssl - end, - - create_config([{port, ?SSL_PORT}, {sock_type, SocketType} | NewConfig], - normal_access, SslNormal), - create_config([{port, ?SSL_PORT}, {sock_type, SocketType} | NewConfig], - mod_htaccess, SslHtaccess), - - %% To be used by IPv6 test cases. Case-clause is so that - %% you can do ts:run(inets, httpd_SUITE, <test case>) - %% for all cases except the ipv6 cases as they depend - %% on 'test_host_ipv6_only' that will only be present - %% when you run the whole test suite due to shortcomings - %% of the test server. - - tsp("init_per_testcase2 -> maybe generate IPv6 config file(s)"), - NewConfig2 = - case atom_to_list(Case) of - "ipv6_" ++ _ -> - case (catch inets_test_lib:has_ipv6_support(NewConfig)) of - {ok, IPv6Address0} -> - {ok, Hostname} = inet:gethostname(), - IPv6Address = http_transport:ipv6_name(IPv6Address0), - create_ipv6_config([{port, ?IP_PORT}, - {sock_type, ip_comm}, - {ipv6_host, IPv6Address} | - NewConfig], - "ipv6_hostname_ipcomm.conf", - Hostname), - create_ipv6_config([{port, ?IP_PORT}, - {sock_type, ip_comm}, - {ipv6_host, IPv6Address} | - NewConfig], - "ipv6_address_ipcomm.conf", - IPv6Address), - create_ipv6_config([{port, ?SSL_PORT}, - {sock_type, essl}, - {ipv6_host, IPv6Address} | - NewConfig], - "ipv6_hostname_essl.conf", - Hostname), - create_ipv6_config([{port, ?SSL_PORT}, - {sock_type, essl}, - {ipv6_host, IPv6Address} | - NewConfig], - "ipv6_address_essl.conf", - IPv6Address), - [{ipv6_host, IPv6Address} | NewConfig]; - _ -> - NewConfig - end; - - _ -> - NewConfig - end, - - %% tsp("init_per_testcase2 -> done when" - %% "~n NewConfig2: ~p", [NewConfig2]), - - NewConfig2. - - -init_per_testcase3(Case, Config) -> - tsp("init_per_testcase3(~w) -> entry with" - "~n Config: ~p", [Case, Config]), - - -%% %% Create a new fresh node to be used by the server in this test-case - -%% NodeName = list_to_atom(atom_to_list(Case) ++ "_httpd"), -%% Node = inets_test_lib:start_node(NodeName), - - %% Clean up (we do not want this clean up in end_per_testcase - %% if init_per_testcase crashes for some testcase it will - %% have contaminated the environment and there will be no clean up.) - %% This init can take a few different paths so that one crashes - %% does not mean that all invocations will. - - application:unset_env(inets, services), - application:stop(inets), - application:stop(ssl), - cleanup_mnesia(), - - %% Start initialization - tsp("init_per_testcase3(~w) -> start init", [Case]), - - Dog = test_server:timetrap(inets_test_lib:minutes(10)), - NewConfig = lists:keydelete(watchdog, 1, Config), - TcTopDir = proplists:get_value(tc_top_dir, Config), - - CaseRest = - case atom_to_list(Case) of - "ip_mod_htaccess" -> - inets_test_lib:start_http_server( - filename:join(TcTopDir, - integer_to_list(?IP_PORT) ++ - "htaccess.conf")), - "mod_htaccess"; - "ip_" ++ Rest -> - inets_test_lib:start_http_server( - filename:join(TcTopDir, - integer_to_list(?IP_PORT) ++ ".conf")), - Rest; - "ticket_5913" -> - HttpdOptions = - [{file, - filename:join(TcTopDir, - integer_to_list(?IP_PORT) ++ ".conf")}, - {accept_timeout,30000}, - {debug,[{exported_functions, - [httpd_manager,httpd_request_handler]}]}], - inets_test_lib:start_http_server(HttpdOptions); - "ticket_"++Rest -> - %% OTP-5913 use the new syntax of inets.config - inets_test_lib:start_http_server([{file, - filename:join(TcTopDir, - integer_to_list(?IP_PORT) ++ ".conf")}]), - Rest; - - [X, $s, $s, $l, $_, $m, $o, $d, $_, $h, $t, $a, $c, $c, $e, $s, $s] -> - ?ENSURE_STARTED([crypto, public_key, ssl]), - SslTag = - case X of - $p -> ssl; % Plain - $e -> essl % Erlang based ssl - end, - case inets_test_lib:start_http_server_ssl( - filename:join(TcTopDir, - integer_to_list(?SSL_PORT) ++ - "htaccess.conf"), SslTag) of - ok -> - "mod_htaccess"; - Other -> - error_logger:info_msg("Other: ~p~n", [Other]), - {skip, "SSL does not seem to be supported"} - end; - [X, $s, $s, $l, $_ | Rest] -> - ?ENSURE_STARTED([crypto, public_key, ssl]), - SslTag = - case X of - $p -> ssl; - $e -> essl - end, - case inets_test_lib:start_http_server_ssl( - filename:join(TcTopDir, - integer_to_list(?SSL_PORT) ++ - ".conf"), SslTag) of - ok -> - Rest; - Other -> - error_logger:info_msg("Other: ~p~n", [Other]), - {skip, "SSL does not seem to be supported"} - end; - "ipv6_" ++ _ = TestCaseStr -> - case inets_test_lib:has_ipv6_support() of - {ok, _} -> - inets_test_lib:start_http_server( - filename:join(TcTopDir, - TestCaseStr ++ ".conf")); - - _ -> - {skip, "Host does not support IPv6"} - end - end, - - InitRes = - case CaseRest of - {skip, _} = Skip -> - Skip; - "mod_auth_" ++ _ -> - start_mnesia(proplists:get_value(node, Config)), - [{watchdog, Dog} | NewConfig]; - "mod_htaccess" -> - ServerRoot = proplists:get_value(server_root, Config), - Path = filename:join([ServerRoot, "htdocs"]), - catch remove_htaccess(Path), - create_htaccess_data(Path, proplists:get_value(address, Config)), - [{watchdog, Dog} | NewConfig]; - "range" -> - ServerRoot = proplists:get_value(server_root, Config), - Path = filename:join([ServerRoot, "htdocs"]), - create_range_data(Path), - [{watchdog, Dog} | NewConfig]; - _ -> - [{watchdog, Dog} | NewConfig] - end, - - tsp("init_per_testcase3(~w) -> done when" - "~n InitRes: ~p", [Case, InitRes]), - - InitRes. - - -%%-------------------------------------------------------------------- -%% Function: end_per_testcase(Case, Config) -> _ -%% Case - atom() -%% Name of the test case that is about to be run. -%% Config - [tuple()] -%% A list of key/value pairs, holding the test case configuration. -%% Description: Cleanup after each test case -%%-------------------------------------------------------------------- -end_per_testcase(Case, Config) -> - Dog = proplists:get_value(watchdog, Config), - test_server:timetrap_cancel(Dog), - end_per_testcase2(Case, lists:keydelete(watchdog, 1, Config)), - ok. - -end_per_testcase2(Case, Config) -> - tsp("end_per_testcase2(~w) -> entry with" - "~n Config: ~p", [Case, Config]), - application:unset_env(inets, services), - application:stop(inets), - application:stop(ssl), - application:stop(crypto), % used by the new ssl (essl test cases) - cleanup_mnesia(), - tsp("end_per_testcase2(~w) -> done", [Case]), - ok. - - -%%------------------------------------------------------------------------- -%% Test cases starts here. -%%------------------------------------------------------------------------- - -%%------------------------------------------------------------------------- -ip_mod_alias(doc) -> - ["Module test: mod_alias"]; -ip_mod_alias(suite) -> - []; -ip_mod_alias(Config) when is_list(Config) -> - httpd_mod:alias(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), proplists:get_value(node, Config)), - ok. - -%%------------------------------------------------------------------------- -ip_mod_actions(doc) -> - ["Module test: mod_actions"]; -ip_mod_actions(suite) -> - []; -ip_mod_actions(Config) when is_list(Config) -> - httpd_mod:actions(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), proplists:get_value(node, Config)), - ok. - -%%------------------------------------------------------------------------- -ip_mod_security(doc) -> - ["Module test: mod_security"]; -ip_mod_security(suite) -> - []; -ip_mod_security(Config) when is_list(Config) -> - ServerRoot = proplists:get_value(server_root, Config), - httpd_mod:security(ServerRoot, ip_comm, ?IP_PORT, - proplists:get_value(host, Config), proplists:get_value(node, Config)), - ok. - -%%------------------------------------------------------------------------- -ip_mod_auth(doc) -> - ["Module test: mod_auth"]; -ip_mod_auth(suite) -> - []; -ip_mod_auth(Config) when is_list(Config) -> - httpd_mod:auth(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), proplists:get_value(node, Config)), - ok. - -%%------------------------------------------------------------------------- -ip_mod_auth_api(doc) -> - ["Module test: mod_auth_api"]; -ip_mod_auth_api(suite) -> - []; -ip_mod_auth_api(Config) when is_list(Config) -> - ServerRoot = proplists:get_value(server_root, Config), - Host = proplists:get_value(host, Config), - Node = proplists:get_value(node, Config), - httpd_mod:auth_api(ServerRoot, "", ip_comm, ?IP_PORT, Host, Node), - httpd_mod:auth_api(ServerRoot, "dets_", ip_comm, ?IP_PORT, Host, Node), - httpd_mod:auth_api(ServerRoot, "mnesia_", ip_comm, ?IP_PORT, Host, Node), - ok. -%%------------------------------------------------------------------------- -ip_mod_auth_mnesia_api(doc) -> - ["Module test: mod_auth_mnesia_api"]; -ip_mod_auth_mnesia_api(suite) -> - []; -ip_mod_auth_mnesia_api(Config) when is_list(Config) -> - httpd_mod:auth_mnesia_api(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_mod_htaccess(doc) -> - ["Module test: mod_htaccess"]; -ip_mod_htaccess(suite) -> - []; -ip_mod_htaccess(Config) when is_list(Config) -> - httpd_mod:htaccess(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_mod_cgi(doc) -> - ["Module test: mod_cgi"]; -ip_mod_cgi(suite) -> - []; -ip_mod_cgi(Config) when is_list(Config) -> - httpd_mod:cgi(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_mod_esi(doc) -> - ["Module test: mod_esi"]; -ip_mod_esi(suite) -> - []; -ip_mod_esi(Config) when is_list(Config) -> - httpd_mod:esi(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), proplists:get_value(node, Config)), - ok. - -%%------------------------------------------------------------------------- -ip_mod_get(doc) -> - ["Module test: mod_get"]; -ip_mod_get(suite) -> - []; -ip_mod_get(Config) when is_list(Config) -> - httpd_mod:get(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), proplists:get_value(node, Config)), - ok. - -%%------------------------------------------------------------------------- -ip_mod_head(doc) -> - ["Module test: mod_head"]; -ip_mod_head(suite) -> - []; -ip_mod_head(Config) when is_list(Config) -> - httpd_mod:head(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_mod_all(doc) -> - ["All modules test"]; -ip_mod_all(suite) -> - []; -ip_mod_all(Config) when is_list(Config) -> - httpd_mod:all(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_load_light(doc) -> - ["Test light load"]; -ip_load_light(suite) -> - []; -ip_load_light(Config) when is_list(Config) -> - httpd_load:load_test(ip_comm, ?IP_PORT, proplists:get_value(host, Config), - proplists:get_value(node, Config), - get_nof_clients(ip_comm, light)), - ok. -%%------------------------------------------------------------------------- -ip_load_medium(doc) -> - ["Test medium load"]; -ip_load_medium(suite) -> - []; -ip_load_medium(Config) when is_list(Config) -> - httpd_load:load_test(ip_comm, ?IP_PORT, proplists:get_value(host, Config), - proplists:get_value(node, Config), - get_nof_clients(ip_comm, medium)), - ok. -%%------------------------------------------------------------------------- -ip_load_heavy(doc) -> - ["Test heavy load"]; -ip_load_heavy(suite) -> - []; -ip_load_heavy(Config) when is_list(Config) -> - httpd_load:load_test(ip_comm, ?IP_PORT, proplists:get_value(host, Config), - proplists:get_value(node, Config), - get_nof_clients(ip_comm, heavy)), - ok. - - -%%------------------------------------------------------------------------- -ip_dos_hostname(doc) -> - ["Denial Of Service (DOS) attack test case"]; -ip_dos_hostname(suite) -> - []; -ip_dos_hostname(Config) when is_list(Config) -> - dos_hostname(ip_comm, ?IP_PORT, proplists:get_value(host, Config), - proplists:get_value(node, Config), ?MAX_HEADER_SIZE), - ok. - - -%%------------------------------------------------------------------------- -ip_time_test(doc) -> - [""]; -ip_time_test(suite) -> - []; -ip_time_test(Config) when is_list(Config) -> - httpd_time_test:t(ip_comm, proplists:get_value(host, Config), ?IP_PORT), - ok. - -%%------------------------------------------------------------------------- -ip_block_503(doc) -> - ["Check that you will receive status code 503 when the server" - " is blocked and 200 when its not blocked."]; -ip_block_503(suite) -> - []; -ip_block_503(Config) when is_list(Config) -> - httpd_block:block_503(ip_comm, ?IP_PORT, proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_block_disturbing_idle(doc) -> - ["Check that you can block/unblock an idle server. The strategy " - "distribing does not really make a difference in this case."]; -ip_block_disturbing_idle(suite) -> - []; -ip_block_disturbing_idle(Config) when is_list(Config) -> - httpd_block:block_disturbing_idle(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_block_non_disturbing_idle(doc) -> - ["Check that you can block/unblock an idle server. The strategy " - "non distribing does not really make a difference in this case."]; -ip_block_non_disturbing_idle(suite) -> - []; -ip_block_non_disturbing_idle(Config) when is_list(Config) -> - httpd_block:block_non_disturbing_idle(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_block_disturbing_active(doc) -> - ["Check that you can block/unblock an active server. The strategy " - "distribing means ongoing requests should be terminated."]; -ip_block_disturbing_active(suite) -> - []; -ip_block_disturbing_active(Config) when is_list(Config) -> - httpd_block:block_disturbing_active(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_block_non_disturbing_active(doc) -> - ["Check that you can block/unblock an idle server. The strategy " - "non distribing means the ongoing requests should be compleated."]; -ip_block_non_disturbing_active(suite) -> - []; -ip_block_non_disturbing_active(Config) when is_list(Config) -> - httpd_block:block_non_disturbing_idle(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - -%%------------------------------------------------------------------------- -ip_block_disturbing_active_timeout_not_released(doc) -> - ["Check that you can block an active server. The strategy " - "distribing means ongoing requests should be compleated" - "if the timeout does not occur."]; -ip_block_disturbing_active_timeout_not_released(suite) -> - []; -ip_block_disturbing_active_timeout_not_released(Config) - when is_list(Config) -> - httpd_block:block_disturbing_active_timeout_not_released(ip_comm, - ?IP_PORT, - proplists:get_value(host, - Config), - proplists:get_value(node, - Config)), - ok. -%%------------------------------------------------------------------------- -ip_block_disturbing_active_timeout_released(doc) -> - ["Check that you can block an active server. The strategy " - "distribing means ongoing requests should be terminated when" - "the timeout occurs."]; -ip_block_disturbing_active_timeout_released(suite) -> - []; -ip_block_disturbing_active_timeout_released(Config) - when is_list(Config) -> - httpd_block:block_disturbing_active_timeout_released(ip_comm, - ?IP_PORT, - proplists:get_value(host, - Config), - proplists:get_value(node, - Config)), - ok. - -%%------------------------------------------------------------------------- -ip_block_non_disturbing_active_timeout_not_released(doc) -> - ["Check that you can block an active server. The strategy " - "non non distribing means ongoing requests should be completed."]; -ip_block_non_disturbing_active_timeout_not_released(suite) -> - []; -ip_block_non_disturbing_active_timeout_not_released(Config) - when is_list(Config) -> - httpd_block: - block_non_disturbing_active_timeout_not_released(ip_comm, - ?IP_PORT, - proplists:get_value(host, - Config), - proplists:get_value(node, - Config)), - ok. -%%------------------------------------------------------------------------- -ip_block_non_disturbing_active_timeout_released(doc) -> - ["Check that you can block an active server. The strategy " - "non non distribing means ongoing requests should be completed. " - "When the timeout occurs the block operation sohould be canceled." ]; -ip_block_non_disturbing_active_timeout_released(suite) -> - []; -ip_block_non_disturbing_active_timeout_released(Config) - when is_list(Config) -> - httpd_block: - block_non_disturbing_active_timeout_released(ip_comm, - ?IP_PORT, - proplists:get_value(host, - Config), - proplists:get_value(node, - Config)), - ok. -%%------------------------------------------------------------------------- -ip_block_disturbing_blocker_dies(doc) -> - []; -ip_block_disturbing_blocker_dies(suite) -> - []; -ip_block_disturbing_blocker_dies(Config) when is_list(Config) -> - httpd_block:disturbing_blocker_dies(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_block_non_disturbing_blocker_dies(doc) -> - []; -ip_block_non_disturbing_blocker_dies(suite) -> - []; -ip_block_non_disturbing_blocker_dies(Config) when is_list(Config) -> - httpd_block:non_disturbing_blocker_dies(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_restart_no_block(doc) -> - [""]; -ip_restart_no_block(suite) -> - []; -ip_restart_no_block(Config) when is_list(Config) -> - httpd_block:restart_no_block(ip_comm, ?IP_PORT, proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_restart_disturbing_block(doc) -> - [""]; -ip_restart_disturbing_block(suite) -> - []; -ip_restart_disturbing_block(Config) when is_list(Config) -> - httpd_block:restart_disturbing_block(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - -%%------------------------------------------------------------------------- -ip_restart_non_disturbing_block(doc) -> - [""]; -ip_restart_non_disturbing_block(suite) -> - []; -ip_restart_non_disturbing_block(Config) when is_list(Config) -> - httpd_block:restart_non_disturbing_block(ip_comm, ?IP_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - -%%------------------------------------------------------------------------- - -essl_mod_alias(doc) -> - ["Module test: mod_alias - using new of configure new SSL"]; -essl_mod_alias(suite) -> - []; -essl_mod_alias(Config) when is_list(Config) -> - ssl_mod_alias(essl, Config). - - -ssl_mod_alias(Tag, Config) -> - httpd_mod:alias(Tag, ?SSL_PORT, - proplists:get_value(host, Config), proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_mod_actions(doc) -> - ["Module test: mod_actions - using new of configure new SSL"]; -essl_mod_actions(suite) -> - []; -essl_mod_actions(Config) when is_list(Config) -> - ssl_mod_actions(essl, Config). - - -ssl_mod_actions(Tag, Config) -> - httpd_mod:actions(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_mod_security(doc) -> - ["Module test: mod_security - using new of configure new SSL"]; -essl_mod_security(suite) -> - []; -essl_mod_security(Config) when is_list(Config) -> - ssl_mod_security(essl, Config). - -ssl_mod_security(Tag, Config) -> - ServerRoot = proplists:get_value(server_root, Config), - httpd_mod:security(ServerRoot, - Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_mod_auth(doc) -> - ["Module test: mod_auth - using new of configure new SSL"]; -essl_mod_auth(suite) -> - []; -essl_mod_auth(Config) when is_list(Config) -> - ssl_mod_auth(essl, Config). - -ssl_mod_auth(Tag, Config) -> - httpd_mod:auth(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - - -essl_mod_auth_api(doc) -> - ["Module test: mod_auth - using new of configure new SSL"]; -essl_mod_auth_api(suite) -> - []; -essl_mod_auth_api(Config) when is_list(Config) -> - ssl_mod_auth_api(essl, Config). - -ssl_mod_auth_api(Tag, Config) -> - ServerRoot = proplists:get_value(server_root, Config), - Host = proplists:get_value(host, Config), - Node = proplists:get_value(node, Config), - httpd_mod:auth_api(ServerRoot, "", Tag, ?SSL_PORT, Host, Node), - httpd_mod:auth_api(ServerRoot, "dets_", Tag, ?SSL_PORT, Host, Node), - httpd_mod:auth_api(ServerRoot, "mnesia_", Tag, ?SSL_PORT, Host, Node), - ok. - - -%%------------------------------------------------------------------------- - - -essl_mod_auth_mnesia_api(doc) -> - ["Module test: mod_auth_mnesia_api - using new of configure new SSL"]; -essl_mod_auth_mnesia_api(suite) -> - []; -essl_mod_auth_mnesia_api(Config) when is_list(Config) -> - ssl_mod_auth_mnesia_api(essl, Config). - -ssl_mod_auth_mnesia_api(Tag, Config) -> - httpd_mod:auth_mnesia_api(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_mod_htaccess(doc) -> - ["Module test: mod_htaccess - using new of configure new SSL"]; -essl_mod_htaccess(suite) -> - []; -essl_mod_htaccess(Config) when is_list(Config) -> - ssl_mod_htaccess(essl, Config). - -ssl_mod_htaccess(Tag, Config) -> - httpd_mod:htaccess(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_mod_cgi(doc) -> - ["Module test: mod_cgi - using new of configure new SSL"]; -essl_mod_cgi(suite) -> - []; -essl_mod_cgi(Config) when is_list(Config) -> - ssl_mod_cgi(essl, Config). - -ssl_mod_cgi(Tag, Config) -> - httpd_mod:cgi(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_mod_esi(doc) -> - ["Module test: mod_esi - using new of configure new SSL"]; -essl_mod_esi(suite) -> - []; -essl_mod_esi(Config) when is_list(Config) -> - ssl_mod_esi(essl, Config). - -ssl_mod_esi(Tag, Config) -> - httpd_mod:esi(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_mod_get(doc) -> - ["Module test: mod_get - using new of configure new SSL"]; -essl_mod_get(suite) -> - []; -essl_mod_get(Config) when is_list(Config) -> - ssl_mod_get(essl, Config). - -ssl_mod_get(Tag, Config) -> - httpd_mod:get(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_mod_head(doc) -> - ["Module test: mod_head - using new of configure new SSL"]; -essl_mod_head(suite) -> - []; -essl_mod_head(Config) when is_list(Config) -> - ssl_mod_head(essl, Config). - -ssl_mod_head(Tag, Config) -> - httpd_mod:head(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_mod_all(doc) -> - ["All modules test - using new of configure new SSL"]; -essl_mod_all(suite) -> - []; -essl_mod_all(Config) when is_list(Config) -> - ssl_mod_all(essl, Config). - -ssl_mod_all(Tag, Config) -> - httpd_mod:all(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_load_light(doc) -> - ["Test light load - using new of configure new SSL"]; -essl_load_light(suite) -> - []; -essl_load_light(Config) when is_list(Config) -> - ssl_load_light(essl, Config). - -ssl_load_light(Tag, Config) -> - httpd_load:load_test(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config), - get_nof_clients(ssl, light)), - ok. - - -%%------------------------------------------------------------------------- - -essl_load_medium(doc) -> - ["Test medium load - using new of configure new SSL"]; -essl_load_medium(suite) -> - []; -essl_load_medium(Config) when is_list(Config) -> - ssl_load_medium(essl, Config). - -ssl_load_medium(Tag, Config) -> - httpd_load:load_test(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config), - get_nof_clients(ssl, medium)), - ok. - - -%%------------------------------------------------------------------------- - -essl_load_heavy(doc) -> - ["Test heavy load - using new of configure new SSL"]; -essl_load_heavy(suite) -> - []; -essl_load_heavy(Config) when is_list(Config) -> - ssl_load_heavy(essl, Config). - -ssl_load_heavy(Tag, Config) -> - httpd_load:load_test(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config), - get_nof_clients(ssl, heavy)), - ok. - - -%%------------------------------------------------------------------------- - - -essl_dos_hostname(doc) -> - ["Denial Of Service (DOS) attack test case - using new of configure new SSL"]; -essl_dos_hostname(suite) -> - []; -essl_dos_hostname(Config) when is_list(Config) -> - ssl_dos_hostname(essl, Config). - -ssl_dos_hostname(Tag, Config) -> - dos_hostname(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config), - ?MAX_HEADER_SIZE), - ok. - - -%%------------------------------------------------------------------------- - - -essl_time_test(doc) -> - ["using new of configure new SSL"]; -essl_time_test(suite) -> - []; -essl_time_test(Config) when is_list(Config) -> - ssl_time_test(essl, Config). - -ssl_time_test(Tag, Config) when is_list(Config) -> - httpd_time_test:t(Tag, - proplists:get_value(host, Config), - ?SSL_PORT), - ok. - - -%%------------------------------------------------------------------------- - - -essl_block_503(doc) -> - ["Check that you will receive status code 503 when the server" - " is blocked and 200 when its not blocked - using new of configure new SSL."]; -essl_block_503(suite) -> - []; -essl_block_503(Config) when is_list(Config) -> - ssl_block_503(essl, Config). - -ssl_block_503(Tag, Config) -> - httpd_block:block_503(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_block_disturbing_idle(doc) -> - ["Check that you can block/unblock an idle server. The strategy " - "distribing does not really make a difference in this case." - "Using new of configure new SSL"]; -essl_block_disturbing_idle(suite) -> - []; -essl_block_disturbing_idle(Config) when is_list(Config) -> - ssl_block_disturbing_idle(essl, Config). - -ssl_block_disturbing_idle(Tag, Config) -> - httpd_block:block_disturbing_idle(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_block_non_disturbing_idle(doc) -> - ["Check that you can block/unblock an idle server. The strategy " - "non distribing does not really make a difference in this case." - "Using new of configure new SSL"]; -essl_block_non_disturbing_idle(suite) -> - []; -essl_block_non_disturbing_idle(Config) when is_list(Config) -> - ssl_block_non_disturbing_idle(essl, Config). - -ssl_block_non_disturbing_idle(Tag, Config) -> - httpd_block:block_non_disturbing_idle(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_block_disturbing_active(doc) -> - ["Check that you can block/unblock an active server. The strategy " - "distribing means ongoing requests should be terminated." - "Using new of configure new SSL"]; -essl_block_disturbing_active(suite) -> - []; -essl_block_disturbing_active(Config) when is_list(Config) -> - ssl_block_disturbing_active(essl, Config). - -ssl_block_disturbing_active(Tag, Config) -> - httpd_block:block_disturbing_active(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_block_non_disturbing_active(doc) -> - ["Check that you can block/unblock an idle server. The strategy " - "non distribing means the ongoing requests should be compleated." - "Using new of configure new SSL"]; -essl_block_non_disturbing_active(suite) -> - []; -essl_block_non_disturbing_active(Config) when is_list(Config) -> - ssl_block_non_disturbing_active(essl, Config). - -ssl_block_non_disturbing_active(Tag, Config) -> - httpd_block:block_non_disturbing_idle(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_block_disturbing_active_timeout_not_released(doc) -> - ["Check that you can block an active server. The strategy " - "distribing means ongoing requests should be compleated" - "if the timeout does not occur." - "Using new of configure new SSL"]; -essl_block_disturbing_active_timeout_not_released(suite) -> - []; -essl_block_disturbing_active_timeout_not_released(Config) - when is_list(Config) -> - ssl_block_disturbing_active_timeout_not_released(essl, Config). - -ssl_block_disturbing_active_timeout_not_released(Tag, Config) -> - Port = ?SSL_PORT, - Host = proplists:get_value(host, Config), - Node = proplists:get_value(node, Config), - httpd_block:block_disturbing_active_timeout_not_released(Tag, - Port, Host, Node), - ok. - - -%%------------------------------------------------------------------------- - -essl_block_disturbing_active_timeout_released(doc) -> - ["Check that you can block an active server. The strategy " - "distribing means ongoing requests should be terminated when" - "the timeout occurs." - "Using new of configure new SSL"]; -essl_block_disturbing_active_timeout_released(suite) -> - []; -essl_block_disturbing_active_timeout_released(Config) - when is_list(Config) -> - ssl_block_disturbing_active_timeout_released(essl, Config). - -ssl_block_disturbing_active_timeout_released(Tag, Config) -> - Port = ?SSL_PORT, - Host = proplists:get_value(host, Config), - Node = proplists:get_value(node, Config), - httpd_block:block_disturbing_active_timeout_released(Tag, - Port, - Host, - Node), - ok. - - -%%------------------------------------------------------------------------- - -essl_block_non_disturbing_active_timeout_not_released(doc) -> - ["Check that you can block an active server. The strategy " - "non non distribing means ongoing requests should be completed." - "Using new of configure new SSL"]; -essl_block_non_disturbing_active_timeout_not_released(suite) -> - []; -essl_block_non_disturbing_active_timeout_not_released(Config) - when is_list(Config) -> - ssl_block_non_disturbing_active_timeout_not_released(essl, Config). - -ssl_block_non_disturbing_active_timeout_not_released(Tag, Config) -> - Port = ?SSL_PORT, - Host = proplists:get_value(host, Config), - Node = proplists:get_value(node, Config), - httpd_block:block_non_disturbing_active_timeout_not_released(Tag, - Port, - Host, - Node), - ok. - - -%%------------------------------------------------------------------------- - - -essl_block_non_disturbing_active_timeout_released(doc) -> - ["Check that you can block an active server. The strategy " - "non distribing means ongoing requests should be completed. " - "When the timeout occurs the block operation sohould be canceled." - "Using new of configure new SSL"]; -essl_block_non_disturbing_active_timeout_released(suite) -> - []; -essl_block_non_disturbing_active_timeout_released(Config) - when is_list(Config) -> - ssl_block_non_disturbing_active_timeout_released(essl, Config). - -ssl_block_non_disturbing_active_timeout_released(Tag, Config) - when is_list(Config) -> - Port = ?SSL_PORT, - Host = proplists:get_value(host, Config), - Node = proplists:get_value(node, Config), - httpd_block:block_non_disturbing_active_timeout_released(Tag, - Port, - Host, - Node), - - ok. - - -%%------------------------------------------------------------------------- - - -essl_block_disturbing_blocker_dies(doc) -> - ["using new of configure new SSL"]; -essl_block_disturbing_blocker_dies(suite) -> - []; -essl_block_disturbing_blocker_dies(Config) when is_list(Config) -> - ssl_block_disturbing_blocker_dies(essl, Config). - -ssl_block_disturbing_blocker_dies(Tag, Config) -> - httpd_block:disturbing_blocker_dies(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - -essl_block_non_disturbing_blocker_dies(doc) -> - ["using new of configure new SSL"]; -essl_block_non_disturbing_blocker_dies(suite) -> - []; -essl_block_non_disturbing_blocker_dies(Config) when is_list(Config) -> - ssl_block_non_disturbing_blocker_dies(essl, Config). - -ssl_block_non_disturbing_blocker_dies(Tag, Config) -> - httpd_block:non_disturbing_blocker_dies(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - - -essl_restart_no_block(doc) -> - ["using new of configure new SSL"]; -essl_restart_no_block(suite) -> - []; -essl_restart_no_block(Config) when is_list(Config) -> - ssl_restart_no_block(essl, Config). - -ssl_restart_no_block(Tag, Config) -> - httpd_block:restart_no_block(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - - -essl_restart_disturbing_block(doc) -> - ["using new of configure new SSL"]; -essl_restart_disturbing_block(suite) -> - []; -essl_restart_disturbing_block(Config) when is_list(Config) -> - ssl_restart_disturbing_block(essl, Config). - -ssl_restart_disturbing_block(Tag, Config) -> - httpd_block:restart_disturbing_block(Tag, ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- - - -essl_restart_non_disturbing_block(doc) -> - ["using new of configure new SSL"]; -essl_restart_non_disturbing_block(suite) -> - []; -essl_restart_non_disturbing_block(Config) when is_list(Config) -> - ssl_restart_non_disturbing_block(essl, Config). - -ssl_restart_non_disturbing_block(Tag, Config) -> - httpd_block:restart_non_disturbing_block(Tag, - ?SSL_PORT, - proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - - -%%------------------------------------------------------------------------- -ip_host(doc) -> - ["Control that the server accepts/rejects requests with/ without host"]; -ip_host(suite)-> - []; -ip_host(Config) when is_list(Config) -> - httpd_1_1:host(ip_comm, ?IP_PORT, proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_chunked(doc) -> - ["Control that the server accepts chunked requests"]; -ip_chunked(suite) -> - []; -ip_chunked(Config) when is_list(Config) -> - httpd_1_1:chunked(ip_comm, ?IP_PORT, proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_expect(doc) -> - ["Control that the server handles request with the expect header " - "field appropiate"]; -ip_expect(suite)-> - []; -ip_expect(Config) when is_list(Config) -> - httpd_1_1:expect(ip_comm, ?IP_PORT, proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_range(doc) -> - ["Control that the server can handle range requests to plain files"]; -ip_range(suite)-> - []; -ip_range(Config) when is_list(Config) -> - httpd_1_1:range(ip_comm, ?IP_PORT, proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_if_test(doc) -> - ["Test that the if - request header fields is handled correclty"]; -ip_if_test(suite) -> - []; -ip_if_test(Config) when is_list(Config) -> - ServerRoot = proplists:get_value(server_root, Config), - DocRoot = filename:join([ServerRoot, "htdocs"]), - httpd_1_1:if_test(ip_comm, ?IP_PORT, proplists:get_value(host, Config), - proplists:get_value(node, Config), DocRoot), - ok. -%%------------------------------------------------------------------------- -ip_http_trace(doc) -> - ["Test the trace module "]; -ip_http_trace(suite) -> - []; -ip_http_trace(Config) when is_list(Config) -> - httpd_1_1:http_trace(ip_comm, ?IP_PORT, proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. -%%------------------------------------------------------------------------- -ip_http1_1_head(doc) -> - ["Test the trace module "]; -ip_http1_1_head(suite)-> - []; -ip_http1_1_head(Config) when is_list(Config) -> - httpd_1_1:head(ip_comm, ?IP_PORT, proplists:get_value(host, Config), - proplists:get_value(node, Config)), - ok. - -%%------------------------------------------------------------------------- -ip_get_0_9(doc) -> - ["Test simple HTTP/0.9 GET"]; -ip_get_0_9(suite)-> - []; -ip_get_0_9(Config) when is_list(Config) -> - Host = proplists:get_value(host, Config), - Node = proplists:get_value(node, Config), - ok = httpd_test_lib:verify_request(ip_comm, Host, ?IP_PORT, Node, - "GET / \r\n\r\n", - [{statuscode, 200}, - {version, "HTTP/0.9"} ]), - %% Without space after uri - ok = httpd_test_lib:verify_request(ip_comm, Host, ?IP_PORT, Node, - "GET /\r\n\r\n", - [{statuscode, 200}, - {version, "HTTP/0.9"} ]), - ok = httpd_test_lib:verify_request(ip_comm, Host, ?IP_PORT, Node, - "GET / HTTP/0.9\r\n\r\n", - [{statuscode, 200}, - {version, "HTTP/0.9"}]), - - ok. -%%------------------------------------------------------------------------- -ip_head_1_0(doc) -> - ["Test HTTP/1.0 HEAD"]; -ip_head_1_0(suite)-> - []; -ip_head_1_0(Config) when is_list(Config) -> - Host = proplists:get_value(host, Config), - Node = proplists:get_value(node, Config), - ok = httpd_test_lib:verify_request(ip_comm, Host, ?IP_PORT, Node, - "HEAD / HTTP/1.0\r\n\r\n", [{statuscode, 200}, - {version, "HTTP/1.0"}]), - - ok. -%%------------------------------------------------------------------------- -ip_get_1_0(doc) -> - ["Test HTTP/1.0 GET"]; -ip_get_1_0(suite)-> - []; -ip_get_1_0(Config) when is_list(Config) -> - Host = proplists:get_value(host, Config), - Node = proplists:get_value(node, Config), - ok = httpd_test_lib:verify_request(ip_comm, Host, ?IP_PORT, Node, - "GET / HTTP/1.0\r\n\r\n", [{statuscode, 200}, - {version, "HTTP/1.0"}]), - - ok. -%%------------------------------------------------------------------------- -ip_post_1_0(doc) -> - ["Test HTTP/1.0 POST"]; -ip_post_1_0(suite)-> - []; -ip_post_1_0(Config) when is_list(Config) -> - Host = proplists:get_value(host, Config), - Node = proplists:get_value(node, Config), - %% Test the post message formatin 1.0! Real post are testes elsewhere - ok = httpd_test_lib:verify_request(ip_comm, Host, ?IP_PORT, Node, - "POST / HTTP/1.0\r\n\r\n " - "Content-Length:6 \r\n\r\nfoobar", - [{statuscode, 500}, {version, "HTTP/1.0"}]), - - ok. -%%------------------------------------------------------------------------- -ip_mod_cgi_chunked_encoding_test(doc) -> - ["Test the trace module "]; -ip_mod_cgi_chunked_encoding_test(suite)-> - []; -ip_mod_cgi_chunked_encoding_test(Config) when is_list(Config) -> - Host = proplists:get_value(host, Config), - Script = - case test_server:os_type() of - {win32, _} -> - "/cgi-bin/printenv.bat"; - _ -> - "/cgi-bin/printenv.sh" - end, - Requests = - ["GET " ++ Script ++ " HTTP/1.1\r\nHost:"++ Host ++"\r\n\r\n", - "GET /cgi-bin/erl/httpd_example/newformat HTTP/1.1\r\nHost:" - ++ Host ++"\r\n\r\n"], - httpd_1_1:mod_cgi_chunked_encoding_test(ip_comm, ?IP_PORT, - Host, - proplists:get_value(node, Config), - Requests), - ok. - -%------------------------------------------------------------------------- - -ipv6_hostname_ipcomm() -> - [{require, ipv6_hosts}]. -ipv6_hostname_ipcomm(X) -> - SocketType = ip_comm, - Port = ?IP_PORT, - ipv6_hostname(SocketType, Port, X). - -ipv6_hostname_essl() -> - [{require, ipv6_hosts}]. -ipv6_hostname_essl(X) -> - SocketType = essl, - Port = ?SSL_PORT, - ipv6_hostname(SocketType, Port, X). - -ipv6_hostname(_SocketType, _Port, doc) -> - ["Test standard ipv6 address"]; -ipv6_hostname(_SocketType, _Port, suite)-> - []; -ipv6_hostname(SocketType, Port, Config) when is_list(Config) -> - tsp("ipv6_hostname -> entry with" - "~n SocketType: ~p" - "~n Port: ~p" - "~n Config: ~p", [SocketType, Port, Config]), - Host = proplists:get_value(host, Config), - URI = "GET HTTP://" ++ - Host ++ ":" ++ integer_to_list(Port) ++ "/ HTTP/1.1\r\n\r\n", - tsp("ipv6_hostname -> Host: ~p", [Host]), - httpd_test_lib:verify_request(SocketType, Host, Port, [inet6], - node(), - URI, - [{statuscode, 200}, {version, "HTTP/1.1"}]), - ok. - -%%------------------------------------------------------------------------- - -ipv6_address_ipcomm() -> - [{require, ipv6_hosts}]. -ipv6_address_ipcomm(X) -> - SocketType = ip_comm, - Port = ?IP_PORT, - ipv6_address(SocketType, Port, X). - -ipv6_address_essl() -> - [{require, ipv6_hosts}]. -ipv6_address_essl(X) -> - SocketType = essl, - Port = ?SSL_PORT, - ipv6_address(SocketType, Port, X). - -ipv6_address(_SocketType, _Port, doc) -> - ["Test standard ipv6 address"]; -ipv6_address(_SocketType, _Port, suite)-> - []; -ipv6_address(SocketType, Port, Config) when is_list(Config) -> - tsp("ipv6_address -> entry with" - "~n SocketType: ~p" - "~n Port: ~p" - "~n Config: ~p", [SocketType, Port, Config]), - Host = proplists:get_value(host, Config), - tsp("ipv6_address -> Host: ~p", [Host]), - URI = "GET HTTP://" ++ - Host ++ ":" ++ integer_to_list(Port) ++ "/ HTTP/1.1\r\n\r\n", - httpd_test_lib:verify_request(SocketType, Host, Port, [inet6], - node(), - URI, - [{statuscode, 200}, {version, "HTTP/1.1"}]), - ok. - - -%%-------------------------------------------------------------------- -ticket_5775(doc) -> - ["Tests that content-length is correct"]; -ticket_5775(suite) -> - []; -ticket_5775(Config) -> - ok=httpd_test_lib:verify_request(ip_comm, proplists:get_value(host, Config), - ?IP_PORT, proplists:get_value(node, Config), - "GET /cgi-bin/erl/httpd_example:get_bin " - "HTTP/1.0\r\n\r\n", - [{statuscode, 200}, - {version, "HTTP/1.0"}]), - ok. -ticket_5865(doc) -> - ["Tests that a header without last-modified is handled"]; -ticket_5865(suite) -> - []; -ticket_5865(Config) -> - ct:skip(as_of_r15_behaviour_of_calendar_has_changed), - Host = proplists:get_value(host,Config), - ServerRoot = proplists:get_value(server_root, Config), - DocRoot = filename:join([ServerRoot, "htdocs"]), - File = filename:join([DocRoot,"last_modified.html"]), - - Bad_mtime = case test_server:os_type() of - {win32, _} -> - {{1600,12,31},{23,59,59}}; - {unix, _} -> - {{1969,12,31},{23,59,59}} - end, - - {ok,FI}=file:read_file_info(File), - - case file:write_file_info(File,FI#file_info{mtime=Bad_mtime}) of - ok -> - ok = httpd_test_lib:verify_request(ip_comm, Host, - ?IP_PORT, proplists:get_value(node, Config), - "GET /last_modified.html" - " HTTP/1.1\r\nHost:" - ++Host++"\r\n\r\n", - [{statuscode, 200}, - {no_header, - "last-modified"}]), - ok; - {error, Reason} -> - Fault = - io_lib:format("Attempt to change the file info to set the" - " preconditions of the test case failed ~p~n", - [Reason]), - {skip, Fault} - end. - -ticket_5913(doc) -> - ["Tests that a header without last-modified is handled"]; -ticket_5913(suite) -> []; -ticket_5913(Config) -> - ok = httpd_test_lib:verify_request(ip_comm, proplists:get_value(host, Config), - ?IP_PORT, proplists:get_value(node, Config), - "GET /cgi-bin/erl/httpd_example:get_bin " - "HTTP/1.0\r\n\r\n", - [{statuscode, 200}, - {version, "HTTP/1.0"}]), - ok. - -ticket_6003(doc) -> - ["Tests that a URI with a bad hexadecimal code is handled"]; -ticket_6003(suite) -> []; -ticket_6003(Config) -> - ok = httpd_test_lib:verify_request(ip_comm, proplists:get_value(host, Config), - ?IP_PORT, proplists:get_value(node, Config), - "GET http://www.erlang.org/%skalle " - "HTTP/1.0\r\n\r\n", - [{statuscode, 400}, - {version, "HTTP/1.0"}]), - ok. - -ticket_7304(doc) -> - ["Tests missing CR in delimiter"]; -ticket_7304(suite) -> - []; -ticket_7304(Config) -> - ok = httpd_test_lib:verify_request(ip_comm, proplists:get_value(host, Config), - ?IP_PORT, proplists:get_value(node, Config), - "GET / HTTP/1.0\r\n\n", - [{statuscode, 200}, - {version, "HTTP/1.0"}]), - ok. - -%%-------------------------------------------------------------------- -%% Internal functions -%%-------------------------------------------------------------------- -dos_hostname(Type, Port, Host, Node, Max) -> - H1 = {"", 200}, - H2 = {"dummy-host.ericsson.se", 200}, - TooLongHeader = lists:append(lists:duplicate(Max + 1, "a")), - H3 = {TooLongHeader, 403}, - Hosts = [H1,H2,H3], - dos_hostname_poll(Type, Host, Port, Node, Hosts). - -%% make_ipv6(T) when is_tuple(T) andalso (size(T) =:= 8) -> -%% make_ipv6(tuple_to_list(T)); - -%% make_ipv6([_, _, _, _, _, _, _, _] = IPV6) -> -%% lists:flatten(io_lib:format("~s:~s:~s:~s:~s:~s:~s:~s", IPV6)). - - -%%-------------------------------------------------------------------- -%% Other help functions -create_config(Config, Access, FileName) -> - ServerRoot = proplists:get_value(server_root, Config), - TcTopDir = proplists:get_value(tc_top_dir, Config), - Port = proplists:get_value(port, Config), - Type = proplists:get_value(sock_type, Config), - Host = proplists:get_value(host, Config), - Mods = io_lib:format("~p", [httpd_mod]), - Funcs = io_lib:format("~p", [ssl_password_cb]), - MaxHdrSz = io_lib:format("~p", [256]), - MaxHdrAct = io_lib:format("~p", [close]), - - io:format(user, - "create_config -> " - "~n ServerRoot: ~p" - "~n TcTopDir: ~p" - "~n Type: ~p" - "~n Port: ~p" - "~n Host: ~p" - "~n", [ServerRoot, TcTopDir, Type, Port, Host]), - - SSL = - if - (Type =:= ssl) orelse - (Type =:= essl) -> - [cline(["SSLCertificateFile ", - filename:join(ServerRoot, "ssl/ssl_server.pem")]), - cline(["SSLCertificateKeyFile ", - filename:join(ServerRoot, "ssl/ssl_server.pem")]), - cline(["SSLCACertificateFile ", - filename:join(ServerRoot, "ssl/ssl_server.pem")]), - cline(["SSLPasswordCallbackModule ", Mods]), - cline(["SSLPasswordCallbackFunction ", Funcs]), - cline(["SSLVerifyClient 0"]), - cline(["SSLVerifyDepth 1"])]; - true -> - [] - end, - ModOrder = - case Access of - mod_htaccess -> - "Modules mod_alias mod_htaccess mod_auth " - "mod_security " - "mod_responsecontrol mod_trace mod_esi " - "mod_actions mod_cgi mod_dir " - "mod_range mod_get " - "mod_head mod_log mod_disk_log"; - _ -> - "Modules mod_alias mod_auth mod_security " - "mod_responsecontrol mod_trace mod_esi " - "mod_actions mod_cgi mod_dir " - "mod_range mod_get " - "mod_head mod_log mod_disk_log" - end, - - %% The test suite currently does not handle an explicit BindAddress. - %% They assume any has been used, that is Addr is always set to undefined! - - %% {ok, Hostname} = inet:gethostname(), - %% {ok, Addr} = inet:getaddr(Hostname, inet6), - %% AddrStr = make_ipv6(Addr), - %% BindAddress = lists:flatten(io_lib:format("~s|inet6", [AddrStr])), - - BindAddress = "*|inet", - %% BindAddress = "*", - - HttpConfig = [ - cline(["Port ", integer_to_list(Port)]), - cline(["ServerName ", Host]), - cline(["SocketType ", atom_to_list(Type)]), - cline([ModOrder]), - %% cline(["LogFormat ", "erlang"]), - cline(["ServerAdmin [email protected]"]), - cline(["BindAddress ", BindAddress]), - cline(["ServerRoot ", ServerRoot]), - cline(["ErrorLog ", TcTopDir, - "/logs/error_log_", integer_to_list(Port)]), - cline(["TransferLog ", TcTopDir, - "/logs/access_log_", integer_to_list(Port)]), - cline(["SecurityLog ", TcTopDir, - "/logs/security_log_", integer_to_list(Port)]), - cline(["ErrorDiskLog ", TcTopDir, - "/logs/error_disk_log_", integer_to_list(Port)]), - cline(["ErrorDiskLogSize ", "190000 ", "11"]), - cline(["TransferDiskLog ", TcTopDir, - "/logs/access_disk_log_", integer_to_list(Port)]), - cline(["TransferDiskLogSize ", "200000 ", "10"]), - cline(["SecurityDiskLog ", TcTopDir, - "/logs/security_disk_log_", integer_to_list(Port)]), - cline(["SecurityDiskLogSize ", "210000 ", "9"]), - cline(["MaxClients 10"]), - cline(["MaxHeaderSize ", MaxHdrSz]), - cline(["MaxHeaderAction ", MaxHdrAct]), - cline(["DocumentRoot ", - filename:join(ServerRoot, "htdocs")]), - cline(["DirectoryIndex ", "index.html ", "welcome.html"]), - cline(["DefaultType ", "text/plain"]), - SSL, - mod_alias_config(ServerRoot), - - config_directory(filename:join([ServerRoot,"htdocs", - "open"]), - "Open Area", - filename:join(ServerRoot, "auth/passwd"), - filename:join(ServerRoot, "auth/group"), - plain, - "user one Aladdin", - filename:join(ServerRoot, "security_data")), - config_directory(filename:join([ServerRoot,"htdocs", - "secret"]), - "Secret Area", - filename:join(ServerRoot, "auth/passwd"), - filename:join(ServerRoot, "auth/group"), - plain, - "group group1 group2", - filename:join(ServerRoot, "security_data")), - config_directory(filename:join([ServerRoot,"htdocs", - "secret", - "top_secret"]), - "Top Secret Area", - filename:join(ServerRoot, "auth/passwd"), - filename:join(ServerRoot, "auth/group"), - plain, - "group group3", - filename:join(ServerRoot, "security_data")), - - config_directory(filename:join([ServerRoot,"htdocs", - "dets_open"]), - "Dets Open Area", - filename:join(ServerRoot, "passwd"), - filename:join(ServerRoot, "group"), - dets, - "user one Aladdin", - filename:join(ServerRoot, "security_data")), - config_directory(filename:join([ServerRoot,"htdocs", - "dets_secret"]), - "Dets Secret Area", - filename:join(ServerRoot, "passwd"), - filename:join(ServerRoot, "group"), - dets, - "group group1 group2", - filename:join(ServerRoot, "security_data")), - config_directory(filename:join([ServerRoot,"htdocs", - "dets_secret", - "top_secret"]), - "Dets Top Secret Area", - filename:join(ServerRoot, "passwd"), - filename:join(ServerRoot, "group"), - dets, - "group group3", - filename:join(ServerRoot, "security_data")), - - config_directory(filename:join([ServerRoot,"htdocs", - "mnesia_open"]), - "Mnesia Open Area", - false, - false, - mnesia, - "user one Aladdin", - filename:join(ServerRoot, "security_data")), - config_directory(filename:join([ServerRoot,"htdocs", - "mnesia_secret"]), - "Mnesia Secret Area", - false, - false, - mnesia, - "group group1 group2", - filename:join(ServerRoot, "security_data")), - config_directory(filename:join( - [ServerRoot, "htdocs", "mnesia_secret", - "top_secret"]), - "Mnesia Top Secret Area", - false, - false, - mnesia, - "group group3", - filename:join(ServerRoot, "security_data")) - ], - ConfigFile = filename:join([TcTopDir, FileName]), - {ok, Fd} = file:open(ConfigFile, [write]), - ok = file:write(Fd, lists:flatten(HttpConfig)), - ok = file:close(Fd). - -config_directory(Dir, AuthName, AuthUserFile, AuthGroupFile, AuthDBType, - Require, SF) -> - file:delete(SF), - [ - cline(["<Directory ", Dir, ">"]), - cline(["SecurityDataFile ", SF]), - cline(["SecurityMaxRetries 3"]), - cline(["SecurityFailExpireTime ", integer_to_list(?FAIL_EXPIRE_TIME)]), - cline(["SecurityBlockTime 1"]), - cline(["SecurityAuthTimeout ", integer_to_list(?AUTH_TIMEOUT)]), - cline(["SecurityCallbackModule ", "httpd_mod"]), - cline_if_set("AuthUserFile", AuthUserFile), - cline_if_set("AuthGroupFile", AuthGroupFile), - cline_if_set("AuthName", AuthName), - cline_if_set("AuthDBType", AuthDBType), - cline(["require ", Require]), - cline(["</Directory>\r\n"]) - ]. - -mod_alias_config(Root) -> - [ - cline(["Alias /icons/ ", filename:join(Root,"icons"), "/"]), - cline(["Alias /pics/ ", filename:join(Root, "icons"), "/"]), - cline(["ScriptAlias /cgi-bin/ ", filename:join(Root, "cgi-bin"), "/"]), - cline(["ScriptAlias /htbin/ ", filename:join(Root, "cgi-bin"), "/"]), - cline(["ErlScriptAlias /cgi-bin/erl httpd_example io"]), - cline(["EvalScriptAlias /eval httpd_example io"]) - ]. - -cline(List) -> - lists:flatten([List, "\r\n"]). - -cline_if_set(_, false) -> - []; -cline_if_set(Name, Var) when is_list(Var) -> - cline([Name, " ", Var]); -cline_if_set(Name, Var) when is_atom(Var) -> - cline([Name, " ", atom_to_list(Var)]). - -getaddr() -> - {ok,HostName} = inet:gethostname(), - {ok,{A1,A2,A3,A4}} = inet:getaddr(HostName,inet), - lists:flatten(io_lib:format("~p.~p.~p.~p",[A1,A2,A3,A4])). - -start_mnesia(Node) -> - case rpc:call(Node, ?MODULE, cleanup_mnesia, []) of - ok -> - ok; - Other -> - tsf({failed_to_cleanup_mnesia, Other}) - end, - case rpc:call(Node, ?MODULE, setup_mnesia, []) of - {atomic, ok} -> - ok; - Other2 -> - tsf({failed_to_setup_mnesia, Other2}) - end, - ok. - -setup_mnesia() -> - setup_mnesia([node()]). - -setup_mnesia(Nodes) -> - ok = mnesia:create_schema(Nodes), - ok = mnesia:start(), - {atomic, ok} = mnesia:create_table(httpd_user, - [{attributes, - record_info(fields, httpd_user)}, - {disc_copies,Nodes}, {type, set}]), - {atomic, ok} = mnesia:create_table(httpd_group, - [{attributes, - record_info(fields, - httpd_group)}, - {disc_copies,Nodes}, {type,bag}]). - -cleanup_mnesia() -> - mnesia:start(), - mnesia:delete_table(httpd_user), - mnesia:delete_table(httpd_group), - stopped = mnesia:stop(), - mnesia:delete_schema([node()]), - ok. - -create_htaccess_data(Path, IpAddress)-> - create_htaccess_dirs(Path), - - create_html_file(filename:join([Path,"ht/open/dummy.html"])), - create_html_file(filename:join([Path,"ht/blocknet/dummy.html"])), - create_html_file(filename:join([Path,"ht/secret/dummy.html"])), - create_html_file(filename:join([Path,"ht/secret/top_secret/dummy.html"])), - - create_htaccess_file(filename:join([Path,"ht/open/.htaccess"]), - Path, "user one Aladdin"), - create_htaccess_file(filename:join([Path,"ht/secret/.htaccess"]), - Path, "group group1 group2"), - create_htaccess_file(filename:join([Path, - "ht/secret/top_secret/.htaccess"]), - Path, "user four"), - create_htaccess_file(filename:join([Path,"ht/blocknet/.htaccess"]), - Path, nouser, IpAddress), - - create_user_group_file(filename:join([Path,"ht","users.file"]), - "one:OnePassword\ntwo:TwoPassword\nthree:" - "ThreePassword\nfour:FourPassword\nAladdin:" - "AladdinPassword"), - create_user_group_file(filename:join([Path,"ht","groups.file"]), - "group1: two one\ngroup2: two three"). - -create_html_file(PathAndFileName)-> - file:write_file(PathAndFileName,list_to_binary( - "<html><head><title>test</title></head> - <body>testar</body></html>")). - -create_htaccess_file(PathAndFileName, BaseDir, RequireData)-> - file:write_file(PathAndFileName, - list_to_binary( - "AuthUserFile "++ BaseDir ++ - "/ht/users.file\nAuthGroupFile "++ BaseDir - ++ "/ht/groups.file\nAuthName Test\nAuthType" - " Basic\n<Limit>\nrequire " ++ RequireData ++ - "\n</Limit>")). - -create_htaccess_file(PathAndFileName, BaseDir, nouser, IpAddress)-> - file:write_file(PathAndFileName,list_to_binary( - "AuthUserFile "++ BaseDir ++ - "/ht/users.file\nAuthGroupFile " ++ - BaseDir ++ "/ht/groups.file\nAuthName" - " Test\nAuthType" - " Basic\n<Limit GET>\n\tallow from " ++ - format_ip(IpAddress, - string:rchr(IpAddress,$.)) ++ - "\n</Limit>")). - -create_user_group_file(PathAndFileName, Data)-> - file:write_file(PathAndFileName, list_to_binary(Data)). - -create_htaccess_dirs(Path)-> - ok = file:make_dir(filename:join([Path,"ht"])), - ok = file:make_dir(filename:join([Path,"ht/open"])), - ok = file:make_dir(filename:join([Path,"ht/blocknet"])), - ok = file:make_dir(filename:join([Path,"ht/secret"])), - ok = file:make_dir(filename:join([Path,"ht/secret/top_secret"])). - -remove_htaccess_dirs(Path)-> - file:del_dir(filename:join([Path,"ht/secret/top_secret"])), - file:del_dir(filename:join([Path,"ht/secret"])), - file:del_dir(filename:join([Path,"ht/blocknet"])), - file:del_dir(filename:join([Path,"ht/open"])), - file:del_dir(filename:join([Path,"ht"])). - -format_ip(IpAddress,Pos)when Pos > 0-> - case lists:nth(Pos,IpAddress) of - $.-> - case lists:nth(Pos-2,IpAddress) of - $.-> - format_ip(IpAddress,Pos-3); - _-> - lists:sublist(IpAddress,Pos-2) ++ "." - end; - _ -> - format_ip(IpAddress,Pos-1) - end; - -format_ip(IpAddress, _Pos)-> - "1" ++ IpAddress. - -remove_htaccess(Path)-> - file:delete(filename:join([Path,"ht/open/dummy.html"])), - file:delete(filename:join([Path,"ht/secret/dummy.html"])), - file:delete(filename:join([Path,"ht/secret/top_secret/dummy.html"])), - file:delete(filename:join([Path,"ht/blocknet/dummy.html"])), - file:delete(filename:join([Path,"ht/blocknet/.htaccess"])), - file:delete(filename:join([Path,"ht/open/.htaccess"])), - file:delete(filename:join([Path,"ht/secret/.htaccess"])), - file:delete(filename:join([Path,"ht/secret/top_secret/.htaccess"])), - file:delete(filename:join([Path,"ht","users.file"])), - file:delete(filename:join([Path,"ht","groups.file"])), - remove_htaccess_dirs(Path). - - -dos_hostname_poll(Type, Host, Port, Node, Hosts) -> - [dos_hostname_poll1(Type, Host, Port, Node, Host1, Code) - || {Host1,Code} <- Hosts]. - -dos_hostname_poll1(Type, Host, Port, Node, Host1, Code) -> - ok = httpd_test_lib:verify_request(Type, Host, Port, Node, - dos_hostname_request(Host1), - [{statuscode, Code}, - {version, "HTTP/1.0"}]). - -dos_hostname_request(Host) -> - "GET / HTTP/1.0\r\n" ++ Host ++ "\r\n\r\n". - -get_nof_clients(Mode, Load) -> - get_nof_clients(test_server:os_type(), Mode, Load). - -get_nof_clients(_, ip_comm, light) -> 5; -get_nof_clients(_, ssl, light) -> 2; -get_nof_clients(_, ip_comm, medium) -> 10; -get_nof_clients(_, ssl, medium) -> 4; -get_nof_clients(_, ip_comm, heavy) -> 20; -get_nof_clients(_, ssl, heavy) -> 6. - -%% Make a file 100 bytes long containing 012...9*10 -create_range_data(Path) -> - PathAndFileName=filename:join([Path,"range.txt"]), - file:write_file(PathAndFileName,list_to_binary(["12345678901234567890", - "12345678901234567890", - "12345678901234567890", - "12345678901234567890", - "12345678901234567890"])). - -create_ipv6_config(Config, FileName, Ipv6Address) -> - ServerRoot = proplists:get_value(server_root, Config), - TcTopDir = proplists:get_value(tc_top_dir, Config), - Port = proplists:get_value(port, Config), - SockType = proplists:get_value(sock_type, Config), - Mods = io_lib:format("~p", [httpd_mod]), - Funcs = io_lib:format("~p", [ssl_password_cb]), - Host = proplists:get_value(ipv6_host, Config), - - MaxHdrSz = io_lib:format("~p", [256]), - MaxHdrAct = io_lib:format("~p", [close]), - - Mod_order = "Modules mod_alias mod_auth mod_esi mod_actions mod_cgi" - " mod_dir mod_get mod_head" - " mod_log mod_disk_log mod_trace", - - SSL = - if - (SockType =:= ssl) orelse - (SockType =:= essl) -> - [cline(["SSLCertificateFile ", - filename:join(ServerRoot, "ssl/ssl_server.pem")]), - cline(["SSLCertificateKeyFile ", - filename:join(ServerRoot, "ssl/ssl_server.pem")]), - cline(["SSLCACertificateFile ", - filename:join(ServerRoot, "ssl/ssl_server.pem")]), - cline(["SSLPasswordCallbackModule ", Mods]), - cline(["SSLPasswordCallbackFunction ", Funcs]), - cline(["SSLVerifyClient 0"]), - cline(["SSLVerifyDepth 1"])]; - true -> - [] - end, - - BindAddress = "[" ++ Ipv6Address ++"]|inet6", - - HttpConfig = - [cline(["BindAddress ", BindAddress]), - cline(["Port ", integer_to_list(Port)]), - cline(["ServerName ", Host]), - cline(["SocketType ", atom_to_list(SockType)]), - cline([Mod_order]), - cline(["ServerRoot ", ServerRoot]), - cline(["DocumentRoot ", filename:join(ServerRoot, "htdocs")]), - cline(["MaxHeaderSize ",MaxHdrSz]), - cline(["MaxHeaderAction ",MaxHdrAct]), - cline(["DirectoryIndex ", "index.html "]), - cline(["DefaultType ", "text/plain"]), - SSL], - ConfigFile = filename:join([TcTopDir,FileName]), - {ok, Fd} = file:open(ConfigFile, [write]), - ok = file:write(Fd, lists:flatten(HttpConfig)), - ok = file:close(Fd). - - -tsp(F) -> - inets_test_lib:tsp("[~w]" ++ F, [?MODULE]). -tsp(F, A) -> - inets_test_lib:tsp("[~w]" ++ F, [?MODULE|A]). - -tsf(Reason) -> - inets_test_lib:tsf(Reason). - diff --git a/lib/inets/test/old_httpd_SUITE_data/Makefile.src b/lib/inets/test/old_httpd_SUITE_data/Makefile.src deleted file mode 100644 index b0fdb43d8d..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/Makefile.src +++ /dev/null @@ -1,14 +0,0 @@ -CC = @CC@ -LD = @LD@ -CFLAGS = @CFLAGS@ -I@erl_include@ @DEFS@ -CROSSLDFLAGS = @CROSSLDFLAGS@ - -PROGS = cgi_echo@exe@ - -all: $(PROGS) - -cgi_echo@exe@: cgi_echo@obj@ - $(LD) $(CROSSLDFLAGS) -o cgi_echo cgi_echo@obj@ @LIBS@ - -cgi_echo@obj@: cgi_echo.c - $(CC) -c -o cgi_echo@obj@ $(CFLAGS) cgi_echo.c diff --git a/lib/inets/test/old_httpd_SUITE_data/cgi_echo.c b/lib/inets/test/old_httpd_SUITE_data/cgi_echo.c deleted file mode 100644 index 580f860e96..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/cgi_echo.c +++ /dev/null @@ -1,97 +0,0 @@ -#include <stdlib.h> -#include <stdio.h> - -#if defined __WIN32__ -#include <windows.h> -#include <fcntl.h> -#endif - -static int read_exact(char *buffer, int len); -static int write_exact(char *buffer, int len); - -int main(void) -{ - char msg[100]; - int msg_len; -#ifdef __WIN32__ - _setmode(_fileno( stdin), _O_BINARY); - _setmode(_fileno( stdout), _O_BINARY); -#endif - msg_len = read_exact(msg, 100); - - write_exact("Content-type: text/plain\r\n\r\n", 28); - write_exact(msg, msg_len); - exit(EXIT_SUCCESS); -} - - -/* read from stdin */ -#ifdef __WIN32__ -static int read_exact(char *buffer, int len) -{ - HANDLE standard_input = GetStdHandle(STD_INPUT_HANDLE); - - unsigned read_result; - unsigned sofar = 0; - - if (!len) { /* Happens for "empty packages */ - return 0; - } - for (;;) { - if (!ReadFile(standard_input, buffer + sofar, - len - sofar, &read_result, NULL)) { - return -1; /* EOF */ - } - if (!read_result) { - return -2; /* Interrupted while reading? */ - } - sofar += read_result; - if (sofar == len) { - return len; - } - } -} -#else -static int read_exact(char *buffer, int len) { - int i, got = 0; - - do { - if ((i = read(0, buffer + got, len - got)) <= 0) - return(i); - got += i; - } while (got < len); - return len; - -} -#endif - -/* write to stdout */ -#ifdef __WIN32__ - static int write_exact(char *buffer, int len) - { - HANDLE standard_output = GetStdHandle(STD_OUTPUT_HANDLE); - unsigned written; - - if (!WriteFile(standard_output, buffer, len, &written, NULL)) { - return -1; /* Broken Pipe */ - } - if (written < ((unsigned) len)) { - /* This should not happen, standard output is not blocking? */ - return -2; - } - - return (int) written; -} - -#else - static int write_exact(char *buffer, int len) { - int i, wrote = 0; - - do { - if ((i = write(1, buffer + wrote, len - wrote)) <= 0) - return i; - wrote += i; - } while (wrote < len); - return len; - } -#endif diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/Makefile b/lib/inets/test/old_httpd_SUITE_data/server_root/Makefile deleted file mode 100644 index ed4d63a3bb..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/Makefile +++ /dev/null @@ -1,210 +0,0 @@ -# -# %CopyrightBegin% -# -# Copyright Ericsson AB 1997-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% -# -# -include $(ERL_TOP)/make/target.mk -include $(ERL_TOP)/make/$(TARGET)/otp.mk - -# ---------------------------------------------------- -# Application version -# ---------------------------------------------------- -include ../../vsn.mk -VSN=$(INETS_VSN) - -# ---------------------------------------------------- -# Release directory specification -# ---------------------------------------------------- -RELSYSDIR = $(RELEASE_PATH)/lib/inets-$(VSN) - -# ---------------------------------------------------- -# Target Specs -# ---------------------------------------------------- -MODULE= - -AUTH_FILES = auth/group \ - auth/passwd -CGI_FILES = cgi-bin/printenv.sh -CONF_FILES = conf/8080.conf \ - conf/8888.conf \ - conf/httpd.conf \ - conf/ssl.conf \ - conf/mime.types -OPEN_FILES = htdocs/open/dummy.html -MNESIA_OPEN_FILES = htdocs/mnesia_open/dummy.html -MISC_FILES = htdocs/misc/friedrich.html \ - htdocs/misc/oech.html -SECRET_FILES = htdocs/secret/dummy.html -MNESIA_SECRET_FILES = htdocs/mnesia_secret/dummy.html -HTDOCS_FILES = htdocs/index.html \ - htdocs/config.shtml \ - htdocs/echo.shtml \ - htdocs/exec.shtml \ - htdocs/flastmod.shtml \ - htdocs/fsize.shtml \ - htdocs/include.shtml -ICON_FILES = icons/README \ - icons/a.gif \ - icons/alert.black.gif \ - icons/alert.red.gif \ - icons/apache_pb.gif \ - icons/back.gif \ - icons/ball.gray.gif \ - icons/ball.red.gif \ - icons/binary.gif \ - icons/binhex.gif \ - icons/blank.gif \ - icons/bomb.gif \ - icons/box1.gif \ - icons/box2.gif \ - icons/broken.gif \ - icons/burst.gif \ - icons/button1.gif \ - icons/button10.gif \ - icons/button2.gif \ - icons/button3.gif \ - icons/button4.gif \ - icons/button5.gif \ - icons/button6.gif \ - icons/button7.gif \ - icons/button8.gif \ - icons/button9.gif \ - icons/buttonl.gif \ - icons/buttonr.gif \ - icons/c.gif \ - icons/comp.blue.gif \ - icons/comp.gray.gif \ - icons/compressed.gif \ - icons/continued.gif \ - icons/dir.gif \ - icons/down.gif \ - icons/dvi.gif \ - icons/f.gif \ - icons/folder.gif \ - icons/folder.open.gif \ - icons/folder.sec.gif \ - icons/forward.gif \ - icons/generic.gif \ - icons/generic.red.gif \ - icons/generic.sec.gif \ - icons/hand.right.gif \ - icons/hand.up.gif \ - icons/htdig.gif \ - icons/icon.sheet.gif \ - icons/image1.gif \ - icons/image2.gif \ - icons/image3.gif \ - icons/index.gif \ - icons/layout.gif \ - icons/left.gif \ - icons/link.gif \ - icons/movie.gif \ - icons/p.gif \ - icons/patch.gif \ - icons/pdf.gif \ - icons/pie0.gif \ - icons/pie1.gif \ - icons/pie2.gif \ - icons/pie3.gif \ - icons/pie4.gif \ - icons/pie5.gif \ - icons/pie6.gif \ - icons/pie7.gif \ - icons/pie8.gif \ - icons/portal.gif \ - icons/poweredby.gif \ - icons/ps.gif \ - icons/quill.gif \ - icons/right.gif \ - icons/screw1.gif \ - icons/screw2.gif \ - icons/script.gif \ - icons/sound1.gif \ - icons/sound2.gif \ - icons/sphere1.gif \ - icons/sphere2.gif \ - icons/star.gif \ - icons/star_blank.gif \ - icons/tar.gif \ - icons/tex.gif \ - icons/text.gif \ - icons/transfer.gif \ - icons/unknown.gif \ - icons/up.gif \ - icons/uu.gif \ - icons/uuencoded.gif \ - icons/world1.gif \ - icons/world2.gif - -SSL_FILES = ssl/ssl_client.pem \ - ssl/ssl_server.pem - -# ---------------------------------------------------- -# FLAGS -# ---------------------------------------------------- -ERL_COMPILE_FLAGS += - -# ---------------------------------------------------- -# Targets -# ---------------------------------------------------- - -debug opt: - -clean: - -docs: - -# ---------------------------------------------------- -# Release Target -# ---------------------------------------------------- -include $(ERL_TOP)/make/otp_release_targets.mk - -release_spec: opt - $(INSTALL_DIR) $(RELSYSDIR)/examples/server_root/auth - $(INSTALL_DATA) $(AUTH_FILES) $(RELSYSDIR)/examples/server_root/auth - $(INSTALL_DIR) $(RELSYSDIR)/examples/server_root/cgi-bin - $(INSTALL_SCRIPT) $(CGI_FILES) $(RELSYSDIR)/examples/server_root/cgi-bin - $(INSTALL_DIR) $(RELSYSDIR)/examples/server_root/conf - $(INSTALL_DATA) $(CONF_FILES) $(RELSYSDIR)/examples/server_root/conf - $(INSTALL_DIR) $(RELSYSDIR)/examples/server_root/htdocs/open - $(INSTALL_DATA) $(OPEN_FILES) \ - $(RELSYSDIR)/examples/server_root/htdocs/open - $(INSTALL_DIR) $(RELSYSDIR)/examples/server_root/htdocs/mnesia_open - $(INSTALL_DATA) $(MNESIA_OPEN_FILES) \ - $(RELSYSDIR)/examples/server_root/htdocs/mnesia_open - $(INSTALL_DIR) $(RELSYSDIR)/examples/server_root/htdocs/misc - $(INSTALL_DATA) $(MISC_FILES) \ - $(RELSYSDIR)/examples/server_root/htdocs/misc - $(INSTALL_DIR) \ - $(RELSYSDIR)/examples/server_root/htdocs/secret/top_secret - $(INSTALL_DIR) \ - $(RELSYSDIR)/examples/server_root/htdocs/mnesia_secret/top_secret - $(INSTALL_DATA) $(SECRET_FILES) \ - $(RELSYSDIR)/examples/server_root/htdocs/secret - $(INSTALL_DATA) $(MNESIA_SECRET_FILES) \ - $(RELSYSDIR)/examples/server_root/htdocs/mnesia_secret - $(INSTALL_DIR) $(RELSYSDIR)/examples/server_root/htdocs - $(INSTALL_DATA) $(HTDOCS_FILES) $(RELSYSDIR)/examples/server_root/htdocs - $(INSTALL_DIR) $(RELSYSDIR)/examples/server_root/icons - $(INSTALL_DATA) $(ICON_FILES) $(RELSYSDIR)/examples/server_root/icons - $(INSTALL_DIR) $(RELSYSDIR)/examples/server_root/ssl - $(INSTALL_DATA) $(SSL_FILES) $(RELSYSDIR)/examples/server_root/ssl - $(INSTALL_DIR) $(RELSYSDIR)/examples/server_root/logs - -release_docs_spec: - diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/auth/group b/lib/inets/test/old_httpd_SUITE_data/server_root/auth/group deleted file mode 100644 index b3da0ccbd3..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/auth/group +++ /dev/null @@ -1,3 +0,0 @@ -group1: one two -group2: two three -group3: three Aladdin diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/auth/passwd b/lib/inets/test/old_httpd_SUITE_data/server_root/auth/passwd deleted file mode 100644 index 8c980ff547..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/auth/passwd +++ /dev/null @@ -1,4 +0,0 @@ -one:onePassword -two:twoPassword -three:threePassword -Aladdin:AladdinPassword diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/cgi-bin/printenv.bat b/lib/inets/test/old_httpd_SUITE_data/server_root/cgi-bin/printenv.bat deleted file mode 100644 index 25a49a1536..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/cgi-bin/printenv.bat +++ /dev/null @@ -1,9 +0,0 @@ -@echo off -echo tomrad > c:\cygwin\tmp\hej -echo Content-type: text/html -echo. -echo ^<HTML^> ^<HEAD^> ^<TITLE^>OS Environment^</TITLE^> ^</HEAD^> ^<BODY^>^<PRE^> -set -echo ^</PRE^>^</BODY^>^</HTML^> - - diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/cgi-bin/printenv.sh b/lib/inets/test/old_httpd_SUITE_data/server_root/cgi-bin/printenv.sh deleted file mode 100755 index de81de9bde..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/cgi-bin/printenv.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/sh -echo "Content-type: text/html" -echo "" -echo "<HTML> <HEAD> <TITLE>OS Environment</TITLE> </HEAD> <BODY><PRE>" -env -echo "</PRE></BODY></HTML>"
\ No newline at end of file diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/8080.conf b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/8080.conf deleted file mode 100644 index 7b1b4a15b2..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/8080.conf +++ /dev/null @@ -1,79 +0,0 @@ -Port 8080 -#ServerName your.server.net -SocketType ip_comm -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_dir mod_get mod_head mod_log mod_disk_log -ServerAdmin [email protected] -ServerRoot /var/tmp/server_root -ErrorLog logs/error_log_8080 -TransferLog logs/access_log_8080 -SecurityLog logs/security_log_8080 -ErrorDiskLog logs/error_disk_log_8080 -ErrorDiskLogSize 200000 10 -TransferDiskLog logs/access_disk_log_8080 -TransferDiskLogSize 200000 10 -SecurityDiskLog logs/security_disk_log -SecurityDiskLogSize 200000 10 -MaxClients 50 -#KeepAlive 5 -#KeepAliveTimeout 10 -DocumentRoot /var/tmp/server_root/htdocs -DirectoryIndex index.html welcome.html -DefaultType text/plain -Alias /icons/ /var/tmp/server_root/icons/ -Alias /pics/ /var/tmp/server_root/icons/ -ScriptAlias /cgi-bin/ /var/tmp/server_root/cgi-bin/ -ScriptAlias /htbin/ /var/tmp/server_root/cgi-bin/ -ErlScriptAlias /cgi-bin/erl httpd_example io -EvalScriptAlias /eval httpd_example io -#Script HEAD /cgi-bin/printenv.sh -#Action image/gif /cgi-bin/printenv.sh - -<Directory /var/tmp/server_root/htdocs/open> -AuthDBType plain -AuthName Open Area -AuthUserFile /var/tmp/server_root/auth/passwd -AuthGroupFile /var/tmp/server_root/auth/group -require user one Aladdin -</Directory> - -<Directory /var/tmp/server_root/htdocs/secret> -AuthDBType plain -AuthName Secret Area -AuthUserFile /var/tmp/server_root/auth/passwd -AuthGroupFile /var/tmp/server_root/auth/group -require group group1 group2 -</Directory> - -<Directory /var/tmp/server_root/htdocs/secret/top_secret> -AuthDBType plain -AuthName Top Secret Area -AuthUserFile /var/tmp/server_root/auth/passwd -AuthGroupFile /var/tmp/server_root/auth/group -require group group3 -</Directory> - -<Directory /var/tmp/server_root/htdocs/mnesia_open> -AuthDBType mnesia -AuthName Open Area -require user one Aladdin -</Directory> - -<Directory /var/tmp/server_root/htdocs/mnesia_secret> -AuthDBType mnesia -AuthName Secret Area -require group group1 group2 -</Directory> - -<Directory /var/tmp/server_root/htdocs/mnesia_secret/top_secret> -AuthDBType mnesia -AuthName Top Secret Area -require group group3 -allow from 130.100.34 130.100.35 -deny from 100.234.22.12 194.100.34.1 130.100.34.25 -SecurityDataFile logs/security_data -SecurityMaxRetries 3 -SecurityBlockTime 10 -SecurityFailExpireTime 1 -SecurityAuthTimeout 1 -SecurityCallbackModule security_callback -</Directory> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/8888.conf b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/8888.conf deleted file mode 100644 index 042779fcd0..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/8888.conf +++ /dev/null @@ -1,63 +0,0 @@ -Port 8888 -#ServerName your.server.net -SocketType ip_comm -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_dir mod_get mod_head mod_log mod_disk_log -ServerAdmin [email protected] -ServerRoot /var/tmp/server_root -ErrorLog logs/error_log_8888 -TransferLog logs/access_log_8888 -ErrorDiskLog logs/error_disk_log_8888 -ErrorDiskLogSize 200000 10 -TransferDiskLog logs/access_disk_log_8888 -TransferDiskLogSize 200000 10 -MaxClients 150 -DocumentRoot /var/tmp/server_root/htdocs -DirectoryIndex index.html welcome.html -DefaultType text/plain -Alias /icons/ /var/tmp/server_root/icons/ -Alias /pics/ /var/tmp/server_root/icons/ -ScriptAlias /cgi-bin/ /var/tmp/server_root/cgi-bin/ -ScriptAlias /htbin/ /var/tmp/server_root/cgi-bin/ -ErlScriptAlias /cgi-bin/erl httpd_example io -EvalScriptAlias /eval httpd_example io -#Script HEAD /cgi-bin/printenv.sh -#Action image/gif /cgi-bin/printenv.sh - -<Directory /var/tmp/server_root/htdocs/open> -AuthName Open Area -AuthUserFile /var/tmp/server_root/auth/passwd -AuthGroupFile /var/tmp/server_root/auth/group -require user one Aladdin -</Directory> - -<Directory /var/tmp/server_root/htdocs/secret> -AuthName Secret Area -AuthUserFile /var/tmp/server_root/auth/passwd -AuthGroupFile /var/tmp/server_root/auth/group -require group group1 group2 -</Directory> - -<Directory /var/tmp/server_root/htdocs/secret/top_secret> -AuthName Top Secret Area -AuthUserFile /var/tmp/server_root/auth/passwd -AuthGroupFile /var/tmp/server_root/auth/group -require group group3 -</Directory> - -<Directory /var/tmp/server_root/htdocs/mnesia_open> -AuthName Open Area -AuthMnesiaDB On -require user one Aladdin -</Directory> - -<Directory /var/tmp/server_root/htdocs/mnesia_secret> -AuthName Secret Area -AuthMnesiaDB On -require group group1 group2 -</Directory> - -<Directory /var/tmp/server_root/htdocs/mnesia_secret/top_secret> -AuthName Top Secret Area -AuthMnesiaDB On -require group group3 -</Directory> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/httpd.conf b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/httpd.conf deleted file mode 100644 index 3add93cd73..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/httpd.conf +++ /dev/null @@ -1,269 +0,0 @@ -# -# %CopyrightBegin% -# -# Copyright Ericsson AB 1997-2017. 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% -# -# - -# Port: The port the standalone listens to. For ports < 1023, you will -# need httpd to be run as root initially. - -Port 8888 - -# BindAddress: This directive is used to tell the server which IP address -# to listen to. It can either contain "*", an IP address, or a fully -# qualified Internet domain name. -# -# It is also possible to specify the ip-family with the directive. -# There ar three possible value: inet, inet6 and inet6fb4 -# inet: Use IpFamily inet when retreiving the address and -# fail if that does not work. -# inet6: Use IpFamily inet6 when retreiving the address and -# fail if that does not work. -# inet6fb4: First IpFamily inet6 is tried and if that does not work, -# inet is used as fallback. -# Default value for ip-family is inet6fb4 -# -# The syntax is: <address>[|<ip-family>] -# -#BindAddress * -#BindAddress *|inet - - -# ServerName allows you to set a host name which is sent back to clients for -# your server if it's different than the one the program would get (i.e. use -# "www" instead of the host's real name). -# -# Note: You cannot just invent host names and hope they work. The name you -# define here must be a valid DNS name for your host. If you don't understand -# this, ask your network administrator. - -#ServerName your.server.net - -# SocketType is either ip_comm, sockets or ssl. - -SocketType ip_comm - -# Modules: Server run-time plug-in modules written using the Erlang -# Web Server API (EWSAPI). The server API make it easy to add functionality -# to the server. Read more about EWSAPI in the Reference Manual. -# WARNING! Do not tamper with this directive unless you are familiar with -# EWSAPI. - -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_responsecontrol mod_trace mod_range mod_head mod_dir mod_get mod_log mod_disk_log - -# ServerAdmin: Your address, where problems with the server should be -# e-mailed. - -ServerAdmin [email protected] - -# ServerRoot: The directory the server's config, error, and log files -# are kept in - -ServerRoot /var/tmp/server_root - -# ErrorLog: The location of the error log file. If this does not start -# with /, ServerRoot is prepended to it. - -ErrorLog logs/error_log - -# TransferLog: The location of the transfer log file. If this does not -# start with /, ServerRoot is prepended to it. - -TransferLog logs/access_log - -# SecurityLog: The location of the security log file (mod_security required) -# -SecurityLog logs/security_log - -# ErrorDiskLog: The location of the error log file. If this does not -# start with /, ServerRoot is prepended to it. This log file is managed -# with the disk_log module [See disk_log(3)]. The ErrorDiskLogSize directive -# takes two argument, i.e. MaxBytes and MaxFiles. The wrap log writes at most -# MaxBytes bytes on each file, and it uses MaxFiles files before it wraps, and -# truncates the first file. - -ErrorDiskLog logs/error_disk_log -ErrorDiskLogSize 200000 10 - -# TransferDiskLog: The location of the transfer log file. If this does not -# start with /, ServerRoot is prepended to it. This log file is managed -# with the disk_log module [See disk_log(3)]. The TransferDiskLogSize directive -# takes two argument, i.e. MaxBytes and MaxFiles. The wrap log writes at most -# MaxBytes bytes on each file, and it uses MaxFiles files before it wraps, and -# truncates the first file. - -TransferDiskLog logs/access_disk_log -TransferDiskLogSize 200000 10 - -# SecurityDiskLog: The location of the security log file. If this does not -# start with /, ServerRoot is prepended to it. This log file is managed -# with the disk_log module [See disk_log(3)]. The SecurityDiskLogSize directive -# takes two argument, i.e. MaxBytes and MaxFiles. The wrap log writes at most -# MaxBytes bytes on each file, and it uses MaxFiles files before it wraps, and -# truncates the first file. - -SecurityDiskLog logs/security_disk_log -SecurityDiskLogSize 200000 10 - -# Limit on total number of servers running, i.e., limit on the number -# of clients who can simultaneously connect --- if this limit is ever -# reached, clients will be LOCKED OUT, so it should NOT BE SET TOO LOW. -# It is intended mainly as a brake to keep a runaway server from taking -# the server with it as it spirals down... - -MaxClients 50 - -# KeepAlive set the flag for persistent connections. For persistent connections -# set KeepAlive to on. To use One request per connection set the flag to off -# Note: The value has changed since previous version of INETS. -KeepAlive on - -# KeepAliveTimeout sets the number of seconds before a persistent connection -# times out and closes. -KeepAliveTimeout 10 - -# MaxKeepAliveRequests sets the number of seconds before a persistent connection -# times out and closes. -MaxKeepAliveRequests 10 - - - -# DocumentRoot: The directory out of which you will serve your -# documents. By default, all requests are taken from this directory, but -# symbolic links and aliases may be used to point to other locations. - -DocumentRoot /var/tmp/server_root/htdocs - -# DirectoryIndex: Name of the file or files to use as a pre-written HTML -# directory index. Separate multiple entries with spaces. - -DirectoryIndex index.html welcome.html - -# DefaultType is the default MIME type for documents which the server -# cannot find the type of from filename extensions. - -DefaultType text/plain - -# Aliases: Add here as many aliases as you need (with no limit). The format is -# Alias fakename realname - -Alias /icons/ /var/tmp/server_root/icons/ -Alias /pics/ /var/tmp/server_root/icons/ - -# ScriptAlias: This controls which directories contain server scripts. -# Format: ScriptAlias fakename realname - -ScriptAlias /cgi-bin/ /var/tmp/server_root/cgi-bin/ -ScriptAlias /htbin/ /var/tmp/server_root/cgi-bin/ - -# This directive adds an action, which will activate cgi-script when a -# file is requested using the method of method, which can be one of -# GET, POST and HEAD. It sends the URL and file path of the requested -# document using the standard CGI PATH_INFO and PATH_TRANSLATED -# environment variables. - -#Script HEAD /cgi-bin/printenv.sh - -# This directive adds an action, which will activate cgi-script when a -# file of content type mime-type is requested. It sends the URL and -# file path of the requested document using the standard CGI PATH_INFO -# and PATH_TRANSLATED environment variables. - -#Action image/gif /cgi-bin/printenv.sh - -# ErlScriptAlias: This specifies how "Erl" server scripts are called. -# Format: ErlScriptAlias fakename realname allowed_modules - -ErlScriptAlias /down/erl httpd_example io - -# EvalScriptAlias: This specifies how "Eval" server scripts are called. -# Format: EvalScriptAlias fakename realname allowed_modules - -EvalScriptAlias /eval httpd_example io - -# Point SSLCertificateFile at a PEM encoded certificate. - -SSLCertificateFile /var/tmp/server_root/ssl/ssl_server.pem - -# If the key is not combined with the certificate, use this directive to -# point at the key file. - -SSLCertificateKeyFile /var/tmp/server_root/ssl/ssl_server.pem - -# Set SSLVerifyClient to: -# 0 if no certicate is required -# 1 if the client may present a valid certificate -# 2 if the client must present a valid certificate -# 3 if the client may present a valid certificate but it is not required to -# have a valid CA - -SSLVerifyClient 0 - -# Each directory to which INETS has access, can be configured with respect -# to which services and features are allowed and/or disabled in that -# directory (and its subdirectories). - -<Directory /var/tmp/server_root/htdocs/open> -AuthDBType plain -AuthName Open Area -AuthUserFile /var/tmp/server_root/auth/passwd -AuthGroupFile /var/tmp/server_root/auth/group -require user one Aladdin -</Directory> - -<Directory /var/tmp/server_root/htdocs/secret> -AuthDBType plain -AuthName Secret Area -AuthUserFile /var/tmp/server_root/auth/passwd -AuthGroupFile /var/tmp/server_root/auth/group -require group group1 group2 -</Directory> - -<Directory /var/tmp/server_root/htdocs/secret/top_secret> -AuthDBType plain -AuthName Top Secret Area -AuthUserFile /var/tmp/server_root/auth/passwd -AuthGroupFile /var/tmp/server_root/auth/group -require group group3 -</Directory> - -<Directory /var/tmp/server_root/htdocs/mnesia_open> -AuthDBType mnesia -AuthName Open Area -require user one Aladdin -</Directory> - -<Directory /var/tmp/server_root/htdocs/mnesia_secret> -AuthDBType mnesia -AuthName Secret Area -require group group1 group2 -</Directory> - -<Directory /var/tmp/server_root/htdocs/mnesia_secret/top_secret> -AuthDBType mnesia -AuthName Top Secret Area -require group group3 -allow from 130.100.34 130.100.35 -deny from 100.234.22.12 194.100.34.1 130.100.34.25 -SecurityDataFile logs/security_data -SecurityMaxRetries 3 -SecurityBlockTime 10 -SecurityFailExpireTime 1 -SecurityAuthTimeout 1 -SecurityCallbackModule security_callback -</Directory> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/mime.types b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/mime.types deleted file mode 100644 index d2f81e4e5e..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/mime.types +++ /dev/null @@ -1,465 +0,0 @@ -# This is a comment. I love comments. - -# MIME type Extension -application/EDI-Consent -application/EDI-X12 -application/EDIFACT -application/activemessage -application/andrew-inset ez -application/applefile -application/atomicmail -application/batch-SMTP -application/beep+xml -application/cals-1840 -application/commonground -application/cybercash -application/dca-rft -application/dec-dx -application/dvcs -application/eshop -application/http -application/hyperstudio -application/iges -application/index -application/index.cmd -application/index.obj -application/index.response -application/index.vnd -application/iotp -application/ipp -application/isup -application/font-tdpfr -application/mac-binhex40 hqx -application/mac-compactpro cpt -application/macwriteii -application/marc -application/mathematica -application/mathematica-old -application/msword doc -application/news-message-id -application/news-transmission -application/ocsp-request -application/ocsp-response -application/octet-stream bin dms lha lzh exe class so dll -application/oda oda -application/parityfec -application/pdf pdf -application/pgp-encrypted -application/pgp-keys -application/pgp-signature -application/pkcs10 -application/pkcs7-mime -application/pkcs7-signature -application/pkix-cert -application/pkix-crl -application/pkixcmp -application/postscript ai eps ps -application/prs.alvestrand.titrax-sheet -application/prs.cww -application/prs.nprend -application/qsig -application/remote-printing -application/riscos -application/rtf -application/sdp -application/set-payment -application/set-payment-initiation -application/set-registration -application/set-registration-initiation -application/sgml -application/sgml-open-catalog -application/sieve -application/slate -application/smil smi smil -application/timestamp-query -application/timestamp-reply -application/vemmi -application/vnd.3M.Post-it-Notes -application/vnd.FloGraphIt -application/vnd.accpac.simply.aso -application/vnd.accpac.simply.imp -application/vnd.acucobol -application/vnd.aether.imp -application/vnd.anser-web-certificate-issue-initiation -application/vnd.anser-web-funds-transfer-initiation -application/vnd.audiograph -application/vnd.businessobjects -application/vnd.bmi -application/vnd.canon-cpdl -application/vnd.canon-lips -application/vnd.claymore -application/vnd.commerce-battelle -application/vnd.commonspace -application/vnd.comsocaller -application/vnd.contact.cmsg -application/vnd.cosmocaller -application/vnd.cups-postscript -application/vnd.cups-raster -application/vnd.cups-raw -application/vnd.ctc-posml -application/vnd.cybank -application/vnd.dna -application/vnd.dpgraph -application/vnd.dxr -application/vnd.ecdis-update -application/vnd.ecowin.chart -application/vnd.ecowin.filerequest -application/vnd.ecowin.fileupdate -application/vnd.ecowin.series -application/vnd.ecowin.seriesrequest -application/vnd.ecowin.seriesupdate -application/vnd.enliven -application/vnd.epson.esf -application/vnd.epson.msf -application/vnd.epson.quickanime -application/vnd.epson.salt -application/vnd.epson.ssf -application/vnd.ericsson.quickcall -application/vnd.eudora.data -application/vnd.fdf -application/vnd.ffsns -application/vnd.framemaker -application/vnd.fsc.weblaunch -application/vnd.fujitsu.oasys -application/vnd.fujitsu.oasys2 -application/vnd.fujitsu.oasys3 -application/vnd.fujitsu.oasysgp -application/vnd.fujitsu.oasysprs -application/vnd.fujixerox.ddd -application/vnd.fujixerox.docuworks -application/vnd.fujixerox.docuworks.binder -application/vnd.fut-misnet -application/vnd.grafeq -application/vnd.groove-account -application/vnd.groove-identity-message -application/vnd.groove-injector -application/vnd.groove-tool-message -application/vnd.groove-tool-template -application/vnd.groove-vcard -application/vnd.hhe.lesson-player -application/vnd.hp-HPGL -application/vnd.hp-PCL -application/vnd.hp-PCLXL -application/vnd.hp-hpid -application/vnd.hp-hps -application/vnd.httphone -application/vnd.hzn-3d-crossword -application/vnd.ibm.afplinedata -application/vnd.ibm.MiniPay -application/vnd.ibm.modcap -application/vnd.informix-visionary -application/vnd.intercon.formnet -application/vnd.intertrust.digibox -application/vnd.intertrust.nncp -application/vnd.intu.qbo -application/vnd.intu.qfx -application/vnd.irepository.package+xml -application/vnd.is-xpr -application/vnd.japannet-directory-service -application/vnd.japannet-jpnstore-wakeup -application/vnd.japannet-payment-wakeup -application/vnd.japannet-registration -application/vnd.japannet-registration-wakeup -application/vnd.japannet-setstore-wakeup -application/vnd.japannet-verification -application/vnd.japannet-verification-wakeup -application/vnd.koan -application/vnd.lotus-1-2-3 -application/vnd.lotus-approach -application/vnd.lotus-freelance -application/vnd.lotus-notes -application/vnd.lotus-organizer -application/vnd.lotus-screencam -application/vnd.lotus-wordpro -application/vnd.mcd -application/vnd.mediastation.cdkey -application/vnd.meridian-slingshot -application/vnd.mif mif -application/vnd.minisoft-hp3000-save -application/vnd.mitsubishi.misty-guard.trustweb -application/vnd.mobius.daf -application/vnd.mobius.dis -application/vnd.mobius.msl -application/vnd.mobius.plc -application/vnd.mobius.txf -application/vnd.motorola.flexsuite -application/vnd.motorola.flexsuite.adsi -application/vnd.motorola.flexsuite.fis -application/vnd.motorola.flexsuite.gotap -application/vnd.motorola.flexsuite.kmr -application/vnd.motorola.flexsuite.ttc -application/vnd.motorola.flexsuite.wem -application/vnd.mozilla.xul+xml -application/vnd.ms-artgalry -application/vnd.ms-asf -application/vnd.ms-excel xls -application/vnd.ms-lrm -application/vnd.ms-powerpoint ppt -application/vnd.ms-project -application/vnd.ms-tnef -application/vnd.ms-works -application/vnd.mseq -application/vnd.msign -application/vnd.music-niff -application/vnd.musician -application/vnd.netfpx -application/vnd.noblenet-directory -application/vnd.noblenet-sealer -application/vnd.noblenet-web -application/vnd.novadigm.EDM -application/vnd.novadigm.EDX -application/vnd.novadigm.EXT -application/vnd.osa.netdeploy -application/vnd.palm -application/vnd.pg.format -application/vnd.pg.osasli -application/vnd.powerbuilder6 -application/vnd.powerbuilder6-s -application/vnd.powerbuilder7 -application/vnd.powerbuilder7-s -application/vnd.powerbuilder75 -application/vnd.powerbuilder75-s -application/vnd.previewsystems.box -application/vnd.publishare-delta-tree -application/vnd.pvi.ptid1 -application/vnd.pwg-xhtml-print+xml -application/vnd.rapid -application/vnd.s3sms -application/vnd.seemail -application/vnd.shana.informed.formdata -application/vnd.shana.informed.formtemplate -application/vnd.shana.informed.interchange -application/vnd.shana.informed.package -application/vnd.sss-cod -application/vnd.sss-dtf -application/vnd.sss-ntf -application/vnd.street-stream -application/vnd.svd -application/vnd.swiftview-ics -application/vnd.triscape.mxs -application/vnd.trueapp -application/vnd.truedoc -application/vnd.tve-trigger -application/vnd.ufdl -application/vnd.uplanet.alert -application/vnd.uplanet.alert-wbxml -application/vnd.uplanet.bearer-choice-wbxml -application/vnd.uplanet.bearer-choice -application/vnd.uplanet.cacheop -application/vnd.uplanet.cacheop-wbxml -application/vnd.uplanet.channel -application/vnd.uplanet.channel-wbxml -application/vnd.uplanet.list -application/vnd.uplanet.list-wbxml -application/vnd.uplanet.listcmd -application/vnd.uplanet.listcmd-wbxml -application/vnd.uplanet.signal -application/vnd.vcx -application/vnd.vectorworks -application/vnd.vidsoft.vidconference -application/vnd.visio -application/vnd.vividence.scriptfile -application/vnd.wap.sic -application/vnd.wap.slc -application/vnd.wap.wbxml wbxml -application/vnd.wap.wmlc wmlc -application/vnd.wap.wmlscriptc wmlsc -application/vnd.webturbo -application/vnd.wrq-hp3000-labelled -application/vnd.wt.stf -application/vnd.xara -application/vnd.xfdl -application/vnd.yellowriver-custom-menu -application/whoispp-query -application/whoispp-response -application/wita -application/wordperfect5.1 -application/x-bcpio bcpio -application/x-cdlink vcd -application/x-chess-pgn pgn -application/x-compress -application/x-cpio cpio -application/x-csh csh -application/x-director dcr dir dxr -application/x-dvi dvi -application/x-futuresplash spl -application/x-gtar gtar -application/x-gzip -application/x-hdf hdf -application/x-javascript js -application/x-koan skp skd skt skm -application/x-latex latex -application/x-netcdf nc cdf -application/x-sh sh -application/x-shar shar -application/x-shockwave-flash swf -application/x-stuffit sit -application/x-sv4cpio sv4cpio -application/x-sv4crc sv4crc -application/x-tar tar -application/x-tcl tcl -application/x-tex tex -application/x-texinfo texinfo texi -application/x-troff t tr roff -application/x-troff-man man -application/x-troff-me me -application/x-troff-ms ms -application/x-ustar ustar -application/x-wais-source src -application/x400-bp -application/xml -application/xml-dtd -application/xml-external-parsed-entity -application/zip zip -audio/32kadpcm -audio/basic au snd -audio/g.722.1 -audio/l16 -audio/midi mid midi kar -audio/mp4a-latm -audio/mpa-robust -audio/mpeg mpga mp2 mp3 -audio/parityfec -audio/prs.sid -audio/telephone-event -audio/tone -audio/vnd.cisco.nse -audio/vnd.cns.anp1 -audio/vnd.cns.inf1 -audio/vnd.digital-winds -audio/vnd.everad.plj -audio/vnd.lucent.voice -audio/vnd.nortel.vbk -audio/vnd.nuera.ecelp4800 -audio/vnd.nuera.ecelp7470 -audio/vnd.nuera.ecelp9600 -audio/vnd.octel.sbc -audio/vnd.qcelp -audio/vnd.rhetorex.32kadpcm -audio/vnd.vmx.cvsd -audio/x-aiff aif aiff aifc -audio/x-mpegurl m3u -audio/x-pn-realaudio ram rm -audio/x-pn-realaudio-plugin rpm -audio/x-realaudio ra -audio/x-wav wav -chemical/x-pdb pdb -chemical/x-xyz xyz -image/bmp bmp -image/cgm -image/g3fax -image/gif gif -image/ief ief -image/jpeg jpeg jpg jpe -image/naplps -image/png png -image/prs.btif -image/prs.pti -image/tiff tiff tif -image/vnd.cns.inf2 -image/vnd.dwg -image/vnd.dxf -image/vnd.fastbidsheet -image/vnd.fpx -image/vnd.fst -image/vnd.fujixerox.edmics-mmr -image/vnd.fujixerox.edmics-rlc -image/vnd.mix -image/vnd.net-fpx -image/vnd.svf -image/vnd.wap.wbmp wbmp -image/vnd.xiff -image/x-cmu-raster ras -image/x-portable-anymap pnm -image/x-portable-bitmap pbm -image/x-portable-graymap pgm -image/x-portable-pixmap ppm -image/x-rgb rgb -image/x-xbitmap xbm -image/x-xpixmap xpm -image/x-xwindowdump xwd -message/delivery-status -message/disposition-notification -message/external-body -message/http -message/news -message/partial -message/rfc822 -message/s-http -model/iges igs iges -model/mesh msh mesh silo -model/vnd.dwf -model/vnd.flatland.3dml -model/vnd.gdl -model/vnd.gs-gdl -model/vnd.gtw -model/vnd.mts -model/vnd.vtu -model/vrml wrl vrml -multipart/alternative -multipart/appledouble -multipart/byteranges -multipart/digest -multipart/encrypted -multipart/form-data -multipart/header-set -multipart/mixed -multipart/parallel -multipart/related -multipart/report -multipart/signed -multipart/voice-message -text/calendar -text/css css -text/directory -text/enriched -text/html html htm -text/parityfec -text/plain asc txt -text/prs.lines.tag -text/rfc822-headers -text/richtext rtx -text/rtf rtf -text/sgml sgml sgm -text/tab-separated-values tsv -text/t140 -text/uri-list -text/vnd.DMClientScript -text/vnd.IPTC.NITF -text/vnd.IPTC.NewsML -text/vnd.abc -text/vnd.curl -text/vnd.flatland.3dml -text/vnd.fly -text/vnd.fmi.flexstor -text/vnd.in3d.3dml -text/vnd.in3d.spot -text/vnd.latex-z -text/vnd.motorola.reflex -text/vnd.ms-mediapackage -text/vnd.wap.si -text/vnd.wap.sl -text/vnd.wap.wml wml -text/vnd.wap.wmlscript wmls -text/x-setext etx -text/x-server-parsed-html shtml -text/xml xml xsl -text/xml-external-parsed-entity -video/mp4v-es -video/mpeg mpeg mpg mpe -video/parityfec -video/pointer -video/quicktime qt mov -video/vnd.fvt -video/vnd.motorola.video -video/vnd.motorola.videop -video/vnd.mpegurl mxu -video/vnd.mts -video/vnd.nokia.interleaved-multimedia -video/vnd.vivo -video/x-msvideo avi -video/x-sgi-movie movie -x-conference/x-cooltalk ice - - - diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/ssl.conf b/lib/inets/test/old_httpd_SUITE_data/server_root/conf/ssl.conf deleted file mode 100644 index de49ceafd0..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/conf/ssl.conf +++ /dev/null @@ -1,66 +0,0 @@ -Port 8088 -#ServerName your.server.net -SocketType ssl -Modules mod_alias mod_auth mod_esi mod_actions mod_cgi mod_dir mod_get mod_head mod_log mod_disk_log -ServerAdmin [email protected] -ServerRoot /var/tmp/server_root -ErrorLog logs/error_log_8088 -TransferLog logs/access_log_8088 -ErrorDiskLog logs/error_disk_log_8088 -ErrorDiskLogSize 200000 10 -TransferDiskLog logs/access_disk_log_8088 -TransferDiskLogSize 200000 10 -MaxClients 150 -DocumentRoot /var/tmp/server_root/htdocs -DirectoryIndex index.html welcome.html -DefaultType text/plain -Alias /icons/ /var/tmp/server_root/icons/ -Alias /pics/ /var/tmp/server_root/icons/ -ScriptAlias /cgi-bin/ /var/tmp/server_root/cgi-bin/ -ScriptAlias /htbin/ /var/tmp/server_root/cgi-bin/ -ErlScriptAlias /cgi-bin/erl httpd_example io -EvalScriptAlias /eval httpd_example io -SSLCertificateFile /var/tmp/server_root/ssl/ssl_server.pem -SSLCertificateKeyFile /var/tmp/server_root/ssl/ssl_server.pem -SSLVerifyClient 0 -#Script HEAD /cgi-bin/printenv.sh -#Action image/gif /cgi-bin/printenv.sh - -<Directory /var/tmp/server_root/htdocs/open> -AuthName Open Area -AuthUserFile /var/tmp/server_root/auth/passwd -AuthGroupFile /var/tmp/server_root/auth/group -require user one Aladdin -</Directory> - -<Directory /var/tmp/server_root/htdocs/secret> -AuthName Secret Area -AuthUserFile /var/tmp/server_root/auth/passwd -AuthGroupFile /var/tmp/server_root/auth/group -require group group1 group2 -</Directory> - -<Directory /var/tmp/server_root/htdocs/secret/top_secret> -AuthName Top Secret Area -AuthUserFile /var/tmp/server_root/auth/passwd -AuthGroupFile /var/tmp/server_root/auth/group -require group group3 -</Directory> - -<Directory /var/tmp/server_root/htdocs/mnesia_open> -AuthName Open Area -AuthMnesiaDB On -require user one Aladdin -</Directory> - -<Directory /var/tmp/server_root/htdocs/mnesia_secret> -AuthName Secret Area -AuthMnesiaDB On -require group group1 group2 -</Directory> - -<Directory /var/tmp/server_root/htdocs/mnesia_secret/top_secret> -AuthName Top Secret Area -AuthMnesiaDB On -require group group3 -</Directory> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/config.shtml b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/config.shtml deleted file mode 100644 index 107e3ff610..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/config.shtml +++ /dev/null @@ -1,70 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/ssi.html (17-Apr-1997)</TITLE> -</HEAD> -<BODY> -<H1>/ssi.html</H1> - -<!-- ************* CONFIG ************* --> - -<!--#config timefmt="%a %b %e %T %Z %Y" sizefmt="abbrev"--> -<!--#config errmsg="[an especially ugly error occurred while processing this directive]"--> - -<!-- ************* INCLUDE ************* --> - -<P>Include /misc/friedrich.html: -<!--#include virtual="/misc/friedrich.html"--> -<P>Include /misc/not_defined.html: <!--#include virtual="/misc/not_defined.html"--> -<P>Include misc/friedrich.html: -<!--#include file="misc/friedrich.html"--> -<P>Include not_defined.html: <!--#include file="not_defined.html"--> - -<P><HR> - -<!-- ************* ECHO ************* --> - -<P>DOCUMENT_NAME: <!--#echo var="DOCUMENT_NAME"--> -<P>DOCUMENT_URI: <!--#echo var="DOCUMENT_URI"--> -<P>QUERY_STRING_UNESCAPED: <!--#echo var="QUERY_STRING_UNESCAPED"--> -<P>DATE_LOCAL: <!--#echo var="DATE_LOCAL"--> -<P>DATE_GMT: <!--#echo var="DATE_GMT"--> -<P>LAST_MODIFIED: <!--#echo var="LAST_MODIFIED"--> -<P>NOT_DEFINED: <!--#echo var="NOT_DEFINED"--> - -<P><HR> - -<!-- ************* FSIZE ************* --> - -<P>Size of index.html: <!--#fsize file="index.html"--> -<P>Size of not_defined.html: <!--#fsize file="not_defined.html"--> -<!--#config sizefmt="bytes"--> -<P>Size of /misc/friedrich.html: <!--#fsize virtual="/misc/friedrich.html"--> -<P>Size of /misc/not_defined.html: <!--#fsize virtual="/misc/not_defined.html"--> - -<P><HR> - -<!-- ************* FLASTMOD ************* --> - -<P>Last modification of index.html: <!--#flastmod file="index.html"--> -<P>Last modification of not_defined.html: <!--#flastmod file="not_defined.html"--> -<P>Last modification of /misc/friedrich.html: <!--#flastmod virtual="/misc/friedrich.html"--> -<P>Last modification of /misc/not_defined.html: <!--#flastmod virtual="/misc/not_defined.html"--> - -<!--#exec cmd="ls"--> -<!--#exec cmd="printenv"--> -<!--#exec cmd="sunemaja"--> - -<!--#exec cgi="/cgi-bin/printenv.sh"--> - -</BODY> -</HTML> - - - - - - - - - - diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/dets_open/dummy.html b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/dets_open/dummy.html deleted file mode 100644 index a6e8a35a04..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/dets_open/dummy.html +++ /dev/null @@ -1,10 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/open/dummy.html (17-Apr-1997)</TITLE> -<!-- Created by: Joakim Greben�, 17-Apr-1997 --> -<!-- Changed by: Joakim Greben�, 17-Apr-1997 --> -</HEAD> -<BODY> -<H1>/open/dummy.html</H1> -</BODY> -</HTML> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/dets_secret/dummy.html b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/dets_secret/dummy.html deleted file mode 100644 index 016b04e540..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/dets_secret/dummy.html +++ /dev/null @@ -1,10 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/secret/dummy.html (17-Apr-1997)</TITLE> -<!-- Created by: Joakim Greben�, 17-Apr-1997 --> -<!-- Changed by: Joakim Greben�, 17-Apr-1997 --> -</HEAD> -<BODY> -<H1>/secret/dummy.html</H1> -</BODY> -</HTML> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/dets_secret/top_secret/index.html b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/dets_secret/top_secret/index.html deleted file mode 100644 index 34db3d5d1a..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/dets_secret/top_secret/index.html +++ /dev/null @@ -1,9 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/secret/top_secret/index.html (04-Feb-1998)</TITLE> -<!-- Created by: Mattias Nilsson, 04-Feb-1998 --> -</HEAD> -<BODY> -<H1>/secret/top_secret/index.html</H1> -</BODY> -</HTML> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/echo.shtml b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/echo.shtml deleted file mode 100644 index 141db5be59..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/echo.shtml +++ /dev/null @@ -1,35 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/echo.shtml</TITLE> -</HEAD> -<BODY> -<H1>/echo.shtml</H1> - -<P>DOCUMENT_NAME: <!--#echo var="DOCUMENT_NAME"--> - -<P>DOCUMENT_URI: <!--#echo var="DOCUMENT_URI"--> - -<P>QUERY_STRING_UNESCAPED: <!--#echo var="QUERY_STRING_UNESCAPED"--> - -<P>DATE_LOCAL: <!--#echo var="DATE_LOCAL"--> - -<P>DATE_GMT: <!--#echo var="DATE_GMT"--> - -<P>LAST_MODIFIED: <!--#echo var="LAST_MODIFIED"--> - -<P>NOT_DEFINED: <!--#echo var="NOT_DEFINED"--> - -<P>[<A HREF="ssi.html">Back</A>] - -</BODY> -</HTML> - - - - - - - - - - diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/exec.shtml b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/exec.shtml deleted file mode 100644 index 97333da898..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/exec.shtml +++ /dev/null @@ -1,30 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/exec.shtml</TITLE> -</HEAD> -<BODY> -<H1>/exec.shtml</H1> -<PRE> -<!--#exec cmd="ls"--> -<HR> -<!--#exec cmd="printenv"--> -<HR> -<!--#exec cmd="sunemaja"--> -<HR> -<!--#exec cgi="/cgi-bin/printenv.sh"--> -</PRE> - -<P>[<A HREF="ssi.html">Back</A>] - -</BODY> -</HTML> - - - - - - - - - - diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/flastmod.shtml b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/flastmod.shtml deleted file mode 100644 index d54c36fe50..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/flastmod.shtml +++ /dev/null @@ -1,29 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/flastmod.shtml</TITLE> -</HEAD> -<BODY> -<H1>/flastmod.shtml</H1> - -<P>Last modification of index.html: <!--#flastmod file="index.html"--> - -<P>Last modification of not_defined.html: <!--#flastmod file="not_defined.html"--> - -<P>Last modification of /misc/friedrich.html: <!--#flastmod virtual="/misc/friedrich.html"--> - -<P>Last modification of /misc/not_defined.html: <!--#flastmod virtual="/misc/not_defined.html"--> - -<P>[<A HREF="ssi.html">Back</A>] - -</BODY> -</HTML> - - - - - - - - - - diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/fsize.shtml b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/fsize.shtml deleted file mode 100644 index 570ee9cf6d..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/fsize.shtml +++ /dev/null @@ -1,29 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/fsize.shtml</TITLE> -</HEAD> -<BODY> -<H1>/fsize.shtml</H1> - -<P>Size of index.html: <!--#fsize file="index.html"--> - -<P>Size of not_defined.html: <!--#fsize file="not_defined.html"--> - -<P>Size of /misc/friedrich.html: <!--#fsize virtual="/misc/friedrich.html"--> - -<P>Size of /misc/not_defined.html: <!--#fsize virtual="/misc/not_defined.html"--> - -<P>[<A HREF="ssi.html">Back</A>] - -</BODY> -</HTML> - - - - - - - - - - diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/include.shtml b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/include.shtml deleted file mode 100644 index 529aad0437..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/include.shtml +++ /dev/null @@ -1,33 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/include.shtml</TITLE> -</HEAD> -<BODY> -<H1>/include.shtml</H1> - -<P>Include /misc/friedrich.html: -<!--#include virtual="/misc/friedrich.html"--> - -<P>Include /misc/not_defined.html: -<!--#include virtual="/misc/not_defined.html"--> - -<P>Include misc/friedrich.html: -<!--#include file="misc/friedrich.html"--> - -<P>Include not_defined.html: -<!--#include file="not_defined.html"--> - -<P>[<A HREF="ssi.html">Back</A>] - -</BODY> -</HTML> - - - - - - - - - - diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/index.html b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/index.html deleted file mode 100644 index cfdc9f9ab7..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/index.html +++ /dev/null @@ -1,25 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/index.html</TITLE> -</HEAD> -<BODY> -<H1>/index.html</H1> - -<STRONG>Server-Side Include (SSI) commands:</STRONG><BR> -<A HREF="config.shtml">config</A><BR> -<A HREF="echo.shtml">echo</A><BR> -<A HREF="exec.shtml">exec</A><BR> -<A HREF="flastmod.shtml">flastmod</A><BR> -<A HREF="fsize.shtml">fsize</A><BR> -<A HREF="include.shtml">include</A><BR> - -<BR> -<BR> - -<STRONG>ESI callback:</STRING><BR> -<A HREF="cgi-bin/erl/httpd_example/get">cgi-bin/erl/httpd_example/get</A><BR> -<A HREF="cgi-bin/erl/httpd_example/yahoo">cgi-bin/erl/httpd_example/yahoo</A><BR> -<A HREF="cgi-bin/erl/httpd_example/test1">cgi-bin/erl/httpd_example/test1</A><BR> - -</BODY> -</HTML> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/last_modified.html b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/last_modified.html deleted file mode 100644 index 65c1790813..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/last_modified.html +++ /dev/null @@ -1,22 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/last_modified.html</TITLE> -</HEAD> -<BODY> -<H1>/last_modified.html</H1> - -<P>This document is only used for test of illegal last-modified date.</P> - - -</BODY> -</HTML> - - - - - - - - - - diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/misc/friedrich.html b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/misc/friedrich.html deleted file mode 100644 index d7953d5df4..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/misc/friedrich.html +++ /dev/null @@ -1,7 +0,0 @@ -<P><CITE> -Talking much about oneself can also be a means to conceal oneself.<BR> --- Friedrich Nietzsche -</CITE> - -<P>Nested Include: -<!--#include file="misc/oech.html"--> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/misc/oech.html b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/misc/oech.html deleted file mode 100644 index 506064bf04..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/misc/oech.html +++ /dev/null @@ -1,4 +0,0 @@ -<P><CITE> -What excuses stand in your way? How can you eliminate them?<BR> --- Roger von Oech -</CITE> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/misc/welcome.html b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/misc/welcome.html deleted file mode 100644 index 8c17451f91..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/misc/welcome.html +++ /dev/null @@ -1 +0,0 @@ -<HTML></HTML> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/mnesia_open/dummy.html b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/mnesia_open/dummy.html deleted file mode 100644 index a6e8a35a04..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/mnesia_open/dummy.html +++ /dev/null @@ -1,10 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/open/dummy.html (17-Apr-1997)</TITLE> -<!-- Created by: Joakim Greben�, 17-Apr-1997 --> -<!-- Changed by: Joakim Greben�, 17-Apr-1997 --> -</HEAD> -<BODY> -<H1>/open/dummy.html</H1> -</BODY> -</HTML> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/mnesia_secret/dummy.html b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/mnesia_secret/dummy.html deleted file mode 100644 index 016b04e540..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/mnesia_secret/dummy.html +++ /dev/null @@ -1,10 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/secret/dummy.html (17-Apr-1997)</TITLE> -<!-- Created by: Joakim Greben�, 17-Apr-1997 --> -<!-- Changed by: Joakim Greben�, 17-Apr-1997 --> -</HEAD> -<BODY> -<H1>/secret/dummy.html</H1> -</BODY> -</HTML> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/mnesia_secret/top_secret/index.html b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/mnesia_secret/top_secret/index.html deleted file mode 100644 index 2d17e8b596..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/mnesia_secret/top_secret/index.html +++ /dev/null @@ -1,9 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/mnesia_secret/top_secret/index.html (04-Feb-1998)</TITLE> -<!-- Created by: Mattias Nilsson, 04-Feb-1998 --> -</HEAD> -<BODY> -<H1>/mnesia_secret/top_secret/index.html</H1> -</BODY> -</HTML> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/open/dummy.html b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/open/dummy.html deleted file mode 100644 index a6e8a35a04..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/open/dummy.html +++ /dev/null @@ -1,10 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/open/dummy.html (17-Apr-1997)</TITLE> -<!-- Created by: Joakim Greben�, 17-Apr-1997 --> -<!-- Changed by: Joakim Greben�, 17-Apr-1997 --> -</HEAD> -<BODY> -<H1>/open/dummy.html</H1> -</BODY> -</HTML> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/secret/dummy.html b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/secret/dummy.html deleted file mode 100644 index 016b04e540..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/secret/dummy.html +++ /dev/null @@ -1,10 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/secret/dummy.html (17-Apr-1997)</TITLE> -<!-- Created by: Joakim Greben�, 17-Apr-1997 --> -<!-- Changed by: Joakim Greben�, 17-Apr-1997 --> -</HEAD> -<BODY> -<H1>/secret/dummy.html</H1> -</BODY> -</HTML> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/secret/top_secret/index.html b/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/secret/top_secret/index.html deleted file mode 100644 index 34db3d5d1a..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/htdocs/secret/top_secret/index.html +++ /dev/null @@ -1,9 +0,0 @@ -<HTML> -<HEAD> -<TITLE>/secret/top_secret/index.html (04-Feb-1998)</TITLE> -<!-- Created by: Mattias Nilsson, 04-Feb-1998 --> -</HEAD> -<BODY> -<H1>/secret/top_secret/index.html</H1> -</BODY> -</HTML> diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/README b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/README deleted file mode 100644 index a1fc5a5a9c..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/README +++ /dev/null @@ -1,161 +0,0 @@ -Public Domain Icons - - These icons were originally made for Mosaic for X and have been - included in the NCSA httpd and Apache server distributions in the - past. They are in the public domain and may be freely included in any - application. The originals were done by Kevin Hughes ([email protected]). - - Many thanks to Andy Polyakov for tuning the icon colors and adding a - few new images. If you'd like to contribute additions or ideas to - this set, please let me know. - - The distribution site for these icons is at: - - http://www.eit.com/goodies/www.icons/ - - Kevin Hughes - September 11, 1995 - - -Suggested Uses - -The following are a few suggestions, to serve as a starting point for ideas. -Please feel free to tweak and rename the icons as you like. - - a.gif - This might be used to represent PostScript or text layout - languages. - - alert.black.gif, alert.red.gif - These can be used to highlight any important items, such as a - README file in a directory. - - back.gif, forward.gif - These can be used as links to go to previous and next areas. - - ball.gray.gif, ball.red.gif - These might be used as bullets. - - binary.gif - This can be used to represent binary files. - - binhex.gif - This can represent BinHex-encoded data. - - blank.gif - This can be used as a placeholder or a spacing element. - - bomb.gif - This can be used to repreesnt core files. - - box1.gif, box2.gif - These icons can be used to represent generic 3D applications and - related files. - - broken.gif - This can represent corrupted data. - - burst.gif - This can call attention to new and important items. - - c.gif - This might represent C source code. - - comp.blue.gif, comp.red.gif - These little computer icons can stand for telnet or FTP - sessions. - - compressed.gif - This may represent compressed data. - - continued.gif - This can be a link to a continued listing of a directory. - - down.gif, up.gif, left.gif, right.gif - These can be used to scroll up, down, left and right in a - listing or may be used to denote items in an outline. - - dvi.gif - This can represent DVI files. - - f.gif - This might represent FORTRAN or Forth source code. - - folder.gif, folder.open.gif, folder.sec.gif - The folder can represent directories. There is also a version - that can represent secure directories or directories that cannot - be viewed. - - generic.gif, generic.sec.gif, generic.red.gif - These can represent generic files, secure files, and important - files, respectively. - - hand.right.gif, hand.up.gif - These can point out important items (pun intended). - - image1.gif, image2.gif, image3.gif - These can represent image formats of various types. - - index.gif - This might represent a WAIS index or search facility. - - layout.gif - This might represent files and formats that contain graphics as - well as text layout, such as HTML and PDF files. - - link.gif - This might represent files that are symbolic links. - - movie.gif - This can represent various movie formats. - - p.gif - This may stand for Perl or Python source code. - - pie0.gif ... pie8.gif - These icons can be used in applications where a list of - documents is returned from a search. The little pie chart images - can denote how relevant the documents may be to your search - query. - - patch.gif - This may stand for patches and diff files. - - portal.gif - This might be a link to an online service or a 3D world. - - ps.gif, quill.gif - These may represent PostScript files. - - screw1.gif, screw2.gif - These may represent CAD or engineering data and formats. - - script.gif - This can represent any of various interpreted languages, such as - Perl, python, TCL, and shell scripts, as well as server - configuration files. - - sound1.gif, sound2.gif - These can represent sound files. - - sphere1.gif, sphere2.gif - These can represent 3D worlds or rendering applications and - formats. - - tex.gif - This can represent TeX files. - - text.gif - This can represent generic (plain) text files. - - transfer.gif - This can represent FTP transfers or uploads/downloads. - - unknown.gif - This may represent a file of an unknown type. - - uuencoded.gif - This can stand for uuencoded data. - - world1.gif, world2.gif - These can represent 3D worlds or other 3D formats. diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/a.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/a.gif Binary files differdeleted file mode 100644 index bb23d971f4..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/a.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/alert.black.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/alert.black.gif Binary files differdeleted file mode 100644 index eaecd2172a..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/alert.black.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/alert.red.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/alert.red.gif Binary files differdeleted file mode 100644 index a423894043..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/alert.red.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/apache_pb.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/apache_pb.gif Binary files differdeleted file mode 100644 index 3a1c139fc4..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/apache_pb.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/back.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/back.gif Binary files differdeleted file mode 100644 index a694ae1ec3..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/back.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/ball.gray.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/ball.gray.gif Binary files differdeleted file mode 100644 index eb84268c4c..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/ball.gray.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/ball.red.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/ball.red.gif Binary files differdeleted file mode 100644 index a8425cb574..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/ball.red.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/binary.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/binary.gif Binary files differdeleted file mode 100644 index 9a15cbae04..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/binary.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/binhex.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/binhex.gif Binary files differdeleted file mode 100644 index 62d0363108..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/binhex.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/blank.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/blank.gif Binary files differdeleted file mode 100644 index 0ccf01e198..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/blank.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/bomb.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/bomb.gif Binary files differdeleted file mode 100644 index 270fdb1c06..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/bomb.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/box1.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/box1.gif Binary files differdeleted file mode 100644 index 65dcd002ea..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/box1.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/box2.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/box2.gif Binary files differdeleted file mode 100644 index c43bc4faec..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/box2.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/broken.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/broken.gif Binary files differdeleted file mode 100644 index 9f8cbe9f76..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/broken.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/burst.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/burst.gif Binary files differdeleted file mode 100644 index fbdcf575f7..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/burst.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button1.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button1.gif Binary files differdeleted file mode 100644 index eb97cb7333..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button1.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button10.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button10.gif Binary files differdeleted file mode 100644 index fe0c97998c..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button10.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button2.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button2.gif Binary files differdeleted file mode 100644 index 7698455bf9..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button2.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button3.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button3.gif Binary files differdeleted file mode 100644 index a8b8319232..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button3.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button4.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button4.gif Binary files differdeleted file mode 100644 index 0fd15a0d7f..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button4.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button5.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button5.gif Binary files differdeleted file mode 100644 index 64241e5c5d..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button5.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button6.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button6.gif Binary files differdeleted file mode 100644 index 867cfd1212..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button6.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button7.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button7.gif Binary files differdeleted file mode 100644 index b3f5fb248f..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button7.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button8.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button8.gif Binary files differdeleted file mode 100644 index 7a308be8f6..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button8.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button9.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button9.gif Binary files differdeleted file mode 100644 index 9acba576c0..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/button9.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/buttonl.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/buttonl.gif Binary files differdeleted file mode 100644 index 3883088e7a..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/buttonl.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/buttonr.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/buttonr.gif Binary files differdeleted file mode 100644 index c4dc3887db..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/buttonr.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/c.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/c.gif Binary files differdeleted file mode 100644 index 7555b6c164..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/c.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/comp.blue.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/comp.blue.gif Binary files differdeleted file mode 100644 index f8d76a8c23..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/comp.blue.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/comp.gray.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/comp.gray.gif Binary files differdeleted file mode 100644 index 7664cd0364..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/comp.gray.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/compressed.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/compressed.gif Binary files differdeleted file mode 100644 index 39e732739f..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/compressed.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/continued.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/continued.gif Binary files differdeleted file mode 100644 index b0ffb7e0cc..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/continued.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/dir.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/dir.gif Binary files differdeleted file mode 100644 index 48264601ae..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/dir.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/down.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/down.gif Binary files differdeleted file mode 100644 index a354c871cd..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/down.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/dvi.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/dvi.gif Binary files differdeleted file mode 100644 index 791be33105..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/dvi.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/f.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/f.gif Binary files differdeleted file mode 100644 index fbe353c282..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/f.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/folder.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/folder.gif Binary files differdeleted file mode 100644 index 48264601ae..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/folder.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/folder.open.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/folder.open.gif Binary files differdeleted file mode 100644 index 30979cb528..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/folder.open.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/folder.sec.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/folder.sec.gif Binary files differdeleted file mode 100644 index 75332d9e59..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/folder.sec.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/forward.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/forward.gif Binary files differdeleted file mode 100644 index b2959b4c85..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/forward.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/generic.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/generic.gif Binary files differdeleted file mode 100644 index de60b2940f..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/generic.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/generic.red.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/generic.red.gif Binary files differdeleted file mode 100644 index 94743981d9..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/generic.red.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/generic.sec.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/generic.sec.gif Binary files differdeleted file mode 100644 index 88d5240c3c..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/generic.sec.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/hand.right.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/hand.right.gif Binary files differdeleted file mode 100644 index 5cdbc7206d..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/hand.right.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/hand.up.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/hand.up.gif Binary files differdeleted file mode 100644 index 85a5d68317..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/hand.up.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/htdig.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/htdig.gif Binary files differdeleted file mode 100644 index 35443fb63a..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/htdig.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/icon.sheet.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/icon.sheet.gif Binary files differdeleted file mode 100644 index ad1686e448..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/icon.sheet.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/image1.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/image1.gif Binary files differdeleted file mode 100644 index 01e442bfa9..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/image1.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/image2.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/image2.gif Binary files differdeleted file mode 100644 index 751faeea36..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/image2.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/image3.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/image3.gif Binary files differdeleted file mode 100644 index 4f30484ff6..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/image3.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/index.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/index.gif Binary files differdeleted file mode 100644 index 162478fb3a..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/index.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/layout.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/layout.gif Binary files differdeleted file mode 100644 index c96338a152..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/layout.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/left.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/left.gif Binary files differdeleted file mode 100644 index 279e6710d4..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/left.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/link.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/link.gif Binary files differdeleted file mode 100644 index c5b6889a76..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/link.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/movie.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/movie.gif Binary files differdeleted file mode 100644 index 0035183774..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/movie.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/p.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/p.gif Binary files differdeleted file mode 100644 index 7b917b4e91..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/p.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/patch.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/patch.gif Binary files differdeleted file mode 100644 index 39bc90e795..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/patch.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pdf.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pdf.gif Binary files differdeleted file mode 100644 index c88fd777c4..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pdf.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie0.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie0.gif Binary files differdeleted file mode 100644 index 6f7a0ae7a7..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie0.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie1.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie1.gif Binary files differdeleted file mode 100644 index 03aa6be71e..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie1.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie2.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie2.gif Binary files differdeleted file mode 100644 index b04c5e0908..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie2.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie3.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie3.gif Binary files differdeleted file mode 100644 index 4db9d023ed..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie3.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie4.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie4.gif Binary files differdeleted file mode 100644 index 93471fdd88..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie4.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie5.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie5.gif Binary files differdeleted file mode 100644 index 57aee93f07..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie5.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie6.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie6.gif Binary files differdeleted file mode 100644 index 0dc327b569..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie6.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie7.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie7.gif Binary files differdeleted file mode 100644 index 8661337f06..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie7.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie8.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie8.gif Binary files differdeleted file mode 100644 index 59ddb34ce0..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/pie8.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/portal.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/portal.gif Binary files differdeleted file mode 100644 index 0e6e506e00..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/portal.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/poweredby.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/poweredby.gif Binary files differdeleted file mode 100644 index d324ab80ea..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/poweredby.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/ps.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/ps.gif Binary files differdeleted file mode 100644 index 0f565bc1db..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/ps.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/quill.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/quill.gif Binary files differdeleted file mode 100644 index 818a5cdc7e..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/quill.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/right.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/right.gif Binary files differdeleted file mode 100644 index b256e5f75f..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/right.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/screw1.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/screw1.gif Binary files differdeleted file mode 100644 index af6ba2b097..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/screw1.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/screw2.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/screw2.gif Binary files differdeleted file mode 100644 index 06dccb3e44..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/screw2.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/script.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/script.gif Binary files differdeleted file mode 100644 index d8a853bc58..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/script.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/sound1.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/sound1.gif Binary files differdeleted file mode 100644 index 8efb49f55d..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/sound1.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/sound2.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/sound2.gif Binary files differdeleted file mode 100644 index 48e6a7fb2f..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/sound2.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/sphere1.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/sphere1.gif Binary files differdeleted file mode 100644 index 7067070da2..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/sphere1.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/sphere2.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/sphere2.gif Binary files differdeleted file mode 100644 index a9e462a377..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/sphere2.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/star.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/star.gif Binary files differdeleted file mode 100644 index 4cfe0a5e0f..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/star.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/star_blank.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/star_blank.gif Binary files differdeleted file mode 100644 index a0c83cb85b..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/star_blank.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/tar.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/tar.gif Binary files differdeleted file mode 100644 index 617e779efa..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/tar.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/tex.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/tex.gif Binary files differdeleted file mode 100644 index 45e43233b8..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/tex.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/text.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/text.gif Binary files differdeleted file mode 100644 index 4c623909fb..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/text.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/transfer.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/transfer.gif Binary files differdeleted file mode 100644 index 33697dbb66..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/transfer.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/unknown.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/unknown.gif Binary files differdeleted file mode 100644 index 32b1ea23fb..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/unknown.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/up.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/up.gif Binary files differdeleted file mode 100644 index 6d6d6d1ebf..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/up.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/uu.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/uu.gif Binary files differdeleted file mode 100644 index 4387d529f6..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/uu.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/uuencoded.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/uuencoded.gif Binary files differdeleted file mode 100644 index 4387d529f6..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/uuencoded.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/world1.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/world1.gif Binary files differdeleted file mode 100644 index 05b4ec2058..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/world1.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/world2.gif b/lib/inets/test/old_httpd_SUITE_data/server_root/icons/world2.gif Binary files differdeleted file mode 100644 index e3203f7a88..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/icons/world2.gif +++ /dev/null diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/logs/Dummy_File_Needed_By_WinZip b/lib/inets/test/old_httpd_SUITE_data/server_root/logs/Dummy_File_Needed_By_WinZip deleted file mode 100644 index 8d1c8b69c3..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/logs/Dummy_File_Needed_By_WinZip +++ /dev/null @@ -1 +0,0 @@ - diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/ssl/ssl_client.pem b/lib/inets/test/old_httpd_SUITE_data/server_root/ssl/ssl_client.pem deleted file mode 100644 index 427447958d..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/ssl/ssl_client.pem +++ /dev/null @@ -1,31 +0,0 @@ ------BEGIN RSA PRIVATE KEY----- -MIICXQIBAAKBgQCTFBPkOO98fDY3j6MIxIGKp+rampfIay50Lx4+EnCnRSSVwC+n -0VVmP7V5SGFJpuXJzN0hvqPUWOOjiMTNlNRaGy0pqu2oMXWAPLOxHWL1wT53h2Zr -3FUNU/N0Rvnkttse1KZJ9uYCLKUiuXXsv2rR62nH3OhRIiBHSAcSv0NRWwIDAQAB -AoGACdIVYe/LTeydUihtInC8lZ2QuPgJmoBNocRjqJFipEihoL4scHAx25n1bBvB -I0HZphffzBkGp28oBAtl2LRPWXqu527unc/RWRfLMqSK1xNSq1DxD1a30zkrZPna -QiV65vEJuNSJTtlDy/Zqc/BVZXCpxWlzYQedZgkmf0Qse8ECQQCmaz02Yur8zC9f -eSQKU5OSzGw3bSIumEzziCfHdTheK6MEoccf5TCAyLXhZwA7QlKja4tFXfeyVxws -/LlnUJN9AkEA4j+xnOeYUyGKXL5i+BAbnqpI4MzPiq+IoCYkaRlD/wAws24r5HNI -ZQmEHWqD/NNzOf/A2XuyLtMiTGJPW/DftwJBAKKpJP6Ytuh6xz8BUCnLwO12Y7vV -LtjuQiCzD3aUa5EYA9HOMqxJPxxRkf0LyR0i2VUkE8+sZiPpov+R0cJa7p0CQQCj -40GUiArGRSiF7/+e84QeVfl+pb29F1QftiFv5DZmFEwy3Z572KpbTh5edJbxYHY6 -UDHxGHJFCvnwXNJhpkVXAkBJqfEfiMJ3Q/E5Gpf3sQizacouW92iiN8ojlF1oB80 -t34RysJH7SgI3gdMhTribCo2UUaV0StjR6yodPN+TB2J ------END RSA PRIVATE KEY----- ------BEGIN CERTIFICATE----- -MIIChzCCAfCgAwIBAgIGAIsapa8BMA0GCSqGSIb3DQEBBQUAMHoxDjAMBgNVBAMT -BW90cENBMSAwHgYJKoZIhvcNAQkBFhF0ZXN0ZXJAZXJsYW5nLm9yZzESMBAGA1UE -BxMJU3RvY2tob2xtMQswCQYDVQQGEwJTRTEPMA0GA1UEChMGZXJsYW5nMRQwEgYD -VQQLEwt0ZXN0aW5nIGRlcDAiGA8yMDEwMDkwMTAwMDAwMFoYDzIwMjUwODI4MDAw -MDAwWjB7MQ8wDQYDVQQDEwZjbGllbnQxIDAeBgkqhkiG9w0BCQEWEXRlc3RlckBl -cmxhbmcub3JnMRIwEAYDVQQHEwlTdG9ja2hvbG0xCzAJBgNVBAYTAlNFMQ8wDQYD -VQQKEwZlcmxhbmcxFDASBgNVBAsTC3Rlc3RpbmcgZGVwMIGfMA0GCSqGSIb3DQEB -AQUAA4GNADCBiQKBgQCTFBPkOO98fDY3j6MIxIGKp+rampfIay50Lx4+EnCnRSSV -wC+n0VVmP7V5SGFJpuXJzN0hvqPUWOOjiMTNlNRaGy0pqu2oMXWAPLOxHWL1wT53 -h2Zr3FUNU/N0Rvnkttse1KZJ9uYCLKUiuXXsv2rR62nH3OhRIiBHSAcSv0NRWwID -AQABoxMwETAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBBQUAA4GBAG8t6f1A -PF7xayGxtUpG2r6W5ETylC3ZIKPS2kfJk9aYi7AZNTp7/xTU6SgqvFBN8aBPzxCD -4jHrSNC8DSb4X1x9uimarb6qdZDHEdij+DRAd2eygJHZxEf7+8B4Fx34thQeU9hZ -S1Izke5AlsyFMkvB7h0anE4k9BfuU70vl6v5 ------END CERTIFICATE----- diff --git a/lib/inets/test/old_httpd_SUITE_data/server_root/ssl/ssl_server.pem b/lib/inets/test/old_httpd_SUITE_data/server_root/ssl/ssl_server.pem deleted file mode 100644 index 4aac86db49..0000000000 --- a/lib/inets/test/old_httpd_SUITE_data/server_root/ssl/ssl_server.pem +++ /dev/null @@ -1,31 +0,0 @@ ------BEGIN RSA PRIVATE KEY----- -MIICXQIBAAKBgQCf4Htxr99lLs5W8QQw7jdakqyAkIjOW4aqH8sr4va4SvZ9Adq6 -7k8jMHefCVZo+F8x4cwsBgB4aWzFIGBnvFTi6YsH27XW7f9O9IPCej8fdhRZ4UAt -NHa253buOWpDGla2JmIdkmfFvXFJycMIKbG5tYilVXoWKBMKmCwWaXz0nQIDAQAB -AoGAQIlma0r6W6bcRj4+Wd4fXCFvHuq5Psu1fYEeC5Yvz8761xVjjSfbrDHJZ9pm -FjOEgedK+s5lbDXqYVyjbdyZSugStBRocSmbG8SQHcAsxR2ZIkNzX2hYzB+lslWo -T3YJojDyB134O7XJznCu+ZFXP86jyJ1JT6k6a+OIHcwnJ+ECQQDYn57dY4Px3mEd -VBLStN3YkRF5oFyT+xk7IaKeLLB6n4gCnoVbBoHut7PFbPYPzoNzEwPk3MQKDIHb -Kig3S5CpAkEAvPA1VmoJWAlN6kUi+F2L8HXEArzE8x7vwdsslrwMKUe4dFS+ZC/7 -5iDOaxcZ7TYkCgwzBt341++DCgP6j3fY1QJBALB6AcOcwi52m6l4B8mu3ZkEPjdX -BHTuONTqhv/TqoaLlxODL2NDvvDKqeMp7KBd/srt79swW2lQXS4+fvrlTdkCQQCm -zxj4O1QWkthkfje6ubSkTwUIOatUzrp1F9GNH2dJRtX2dx9FCwxGCC7WY6XzRXqa -GF0wsedSllbGD+82nWQlAkAicMGqCqRq4hKR/cVmFatOqKVWCVkx6OFF2FhuiI5Z -h5eIOPGCt8dVRs1P9DNSld/D98Sfm65m85z8BtXovvYV ------END RSA PRIVATE KEY----- ------BEGIN CERTIFICATE----- -MIIChzCCAfCgAwIBAgIGANUxXM9BMA0GCSqGSIb3DQEBBQUAMHoxDjAMBgNVBAMT -BW90cENBMSAwHgYJKoZIhvcNAQkBFhF0ZXN0ZXJAZXJsYW5nLm9yZzESMBAGA1UE -BxMJU3RvY2tob2xtMQswCQYDVQQGEwJTRTEPMA0GA1UEChMGZXJsYW5nMRQwEgYD -VQQLEwt0ZXN0aW5nIGRlcDAiGA8yMDEwMDkwMTAwMDAwMFoYDzIwMjUwODI4MDAw -MDAwWjB7MQ8wDQYDVQQDEwZzZXJ2ZXIxIDAeBgkqhkiG9w0BCQEWEXRlc3RlckBl -cmxhbmcub3JnMRIwEAYDVQQHEwlTdG9ja2hvbG0xCzAJBgNVBAYTAlNFMQ8wDQYD -VQQKEwZlcmxhbmcxFDASBgNVBAsTC3Rlc3RpbmcgZGVwMIGfMA0GCSqGSIb3DQEB -AQUAA4GNADCBiQKBgQCf4Htxr99lLs5W8QQw7jdakqyAkIjOW4aqH8sr4va4SvZ9 -Adq67k8jMHefCVZo+F8x4cwsBgB4aWzFIGBnvFTi6YsH27XW7f9O9IPCej8fdhRZ -4UAtNHa253buOWpDGla2JmIdkmfFvXFJycMIKbG5tYilVXoWKBMKmCwWaXz0nQID -AQABoxMwETAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBBQUAA4GBAGF5Pfwk -QDdwJup/mVITPxbBls4Yl7anDooUQsq8066lA1g54H/PRfXscGkyCFGh1ifXvf1L -psMRoBAdDHL/wSJplk3rRavkC94eBgnTFZmfKL6844g1j53yameiYL8IEVExYMBg -/XGyc0qwq57WT8B/K4aElrvlBlQ0wF3wN54M ------END CERTIFICATE----- diff --git a/lib/inets/vsn.mk b/lib/inets/vsn.mk index 34b6902747..05cf4f6cc3 100644 --- a/lib/inets/vsn.mk +++ b/lib/inets/vsn.mk @@ -19,6 +19,6 @@ # %CopyrightEnd% APPLICATION = inets -INETS_VSN = 6.4.2 +INETS_VSN = 6.4.5 PRE_VSN = APP_VSN = "$(APPLICATION)-$(INETS_VSN)$(PRE_VSN)" diff --git a/lib/jinterface/doc/src/Makefile b/lib/jinterface/doc/src/Makefile index 7eb0e20b4d..37de0a35c5 100644 --- a/lib/jinterface/doc/src/Makefile +++ b/lib/jinterface/doc/src/Makefile @@ -46,12 +46,11 @@ XML_PART_FILES = \ part.xml XML_CHAPTER_FILES = \ notes.xml \ - notes_history.xml \ jinterface_users_guide.xml BOOK_FILES = book.xml -XML_FILES = $(BOOK_FILES) $(XML_APPLICATION_FILES) $(XML_REF3_FILES) \ +XML_FILES = $(BOOK_FILES) $(XML_APP_FILES) $(XML_REF3_FILES) \ $(XML_PART_FILES) $(XML_CHAPTER_FILES) GIF_FILES = diff --git a/lib/jinterface/doc/src/notes.xml b/lib/jinterface/doc/src/notes.xml index b44a04d7cd..346d467c2d 100644 --- a/lib/jinterface/doc/src/notes.xml +++ b/lib/jinterface/doc/src/notes.xml @@ -31,6 +31,21 @@ </header> <p>This document describes the changes made to the Jinterface application.</p> +<section><title>Jinterface 1.8.1</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + <section><title>Jinterface 1.8</title> <section><title>Improvements and New Features</title> diff --git a/lib/jinterface/java_src/com/ericsson/otp/erlang/Makefile b/lib/jinterface/java_src/com/ericsson/otp/erlang/Makefile index e55cfa62ea..001acfdd2e 100644 --- a/lib/jinterface/java_src/com/ericsson/otp/erlang/Makefile +++ b/lib/jinterface/java_src/com/ericsson/otp/erlang/Makefile @@ -130,7 +130,6 @@ release_spec: opt release_docs_spec: - - +xmllint: # ---------------------------------------------------- diff --git a/lib/jinterface/java_src/pom.xml.src b/lib/jinterface/java_src/pom.xml.src index 98232db78c..584bd81076 100644 --- a/lib/jinterface/java_src/pom.xml.src +++ b/lib/jinterface/java_src/pom.xml.src @@ -76,6 +76,17 @@ </plugin> <plugin> <groupId>org.apache.maven.plugins</groupId> + <artifactId>maven-jar-plugin</artifactId> + <configuration> + <archive> + <manifestEntries> + <Automatic-Module-Name>com.ericsson.otp.erlang</Automatic-Module-Name> + </manifestEntries> + </archive> + </configuration> + </plugin> + <plugin> + <groupId>org.apache.maven.plugins</groupId> <artifactId>maven-javadoc-plugin</artifactId> <version>2.10.3</version> <executions> diff --git a/lib/jinterface/test/nc_SUITE.erl b/lib/jinterface/test/nc_SUITE.erl index 81944f71d4..daa17195ee 100644 --- a/lib/jinterface/test/nc_SUITE.erl +++ b/lib/jinterface/test/nc_SUITE.erl @@ -651,11 +651,10 @@ do_echo(DataList, Config, OutTrans, InTrans, ExtraArgs) echo_loop([D|Ds], Echoer, OutTrans, InTrans, TermAcc) -> OutMsg = OutTrans(D), Echoer ! OutMsg, - io:format("echo_server ~p: ~p ! ~P~n", [self(),Echoer,OutMsg,10]), + %%io:format("echo_server ~p: ~p ! ~P~n", [self(),Echoer,OutMsg,10]), receive Reply -> - io:format("echo_server ~p: receive ~P~n", - [self(),Reply,10]), + %%io:format("echo_server ~p: receive ~P~n", [self(),Reply,10]), InTrans(Echoer, D, Reply) end, Term = case OutMsg of @@ -670,11 +669,10 @@ echo_loop(Cont, Echoer, OutTrans, InTrans, TermAcc) when is_function(Cont, 0) -> check_terms(Echoer, TermAcc), OutMsg = Echoer ! {self(),undefined,hash_clear}, - io:format("echo_server ~p: ~p ! ~P~n", [self(),Echoer,OutMsg,10]), + %%io:format("echo_server ~p: ~p ! ~P~n", [self(),Echoer,OutMsg,10]), receive {Echoer,hash_cleared,hash_clear}=Reply -> - io:format("echo_server ~p: receive ~P~n", - [self(),Reply,10]), + %%io:format("echo_server ~p: receive ~P~n", [self(),Reply,10]), ok; Other -> io:format("echo_server_terms unexpected ~p: receive ~P~n", @@ -686,11 +684,10 @@ echo_loop(Cont, Echoer, OutTrans, InTrans, TermAcc) check_terms(Echoer, [Term | Rest]) -> OutMsg = {self(),Term,hash_lookup}, Echoer ! OutMsg, - io:format("check_terms ~p: ~p ! ~P~n", [self(),Echoer,OutMsg,10]), + %%io:format("check_terms ~p: ~p ! ~P~n", [self(),Echoer,OutMsg,10]), receive {Echoer,true,hash_lookup} = ReplyMsg -> - io:format("check_terms ~p: receive ~P~n", - [self(),ReplyMsg,10]), + %%io:format("check_terms ~p: receive ~P~n", [self(),ReplyMsg,10]), check_terms(Echoer, Rest); Other -> io:format("check_terms unexpected ~p: receive ~P~n", diff --git a/lib/jinterface/vsn.mk b/lib/jinterface/vsn.mk index 373e2dab22..0a8a1190ec 100644 --- a/lib/jinterface/vsn.mk +++ b/lib/jinterface/vsn.mk @@ -1 +1 @@ -JINTERFACE_VSN = 1.8 +JINTERFACE_VSN = 1.8.1 diff --git a/lib/kernel/doc/src/Makefile b/lib/kernel/doc/src/Makefile index c9d23ac4c4..0759f362d4 100644 --- a/lib/kernel/doc/src/Makefile +++ b/lib/kernel/doc/src/Makefile @@ -71,7 +71,7 @@ XML_REF4_FILES = app.xml config.xml XML_REF6_FILES = kernel_app.xml XML_PART_FILES = -XML_CHAPTER_FILES = notes.xml notes_history.xml +XML_CHAPTER_FILES = notes.xml BOOK_FILES = book.xml diff --git a/lib/kernel/doc/src/file.xml b/lib/kernel/doc/src/file.xml index 2ab35b9b05..8477b0e148 100644 --- a/lib/kernel/doc/src/file.xml +++ b/lib/kernel/doc/src/file.xml @@ -33,11 +33,14 @@ <description> <p>This module provides an interface to the file system.</p> - <p>On operating systems with thread support, - file operations can be performed in threads of their own, allowing - other Erlang processes to continue executing in parallel with - the file operations. See command-line flag - <c>+A</c> in <seealso marker="erts:erl"><c>erl(1)</c></seealso>.</p> + <warning> + <p>File operations are only guaranteed to appear atomic when going + through the same file server. A NIF or other OS process may observe + intermediate steps on certain operations on some operating systems, + eg. renaming an existing file on Windows, or + <seealso marker="#write_file_info/2"><c>write_file_info/2</c> + </seealso> on any OS at the time of writing.</p> + </warning> <p>Regarding filename encoding, the Erlang VM can operate in two modes. The current mode can be queried using function @@ -90,13 +93,6 @@ are now <em>rejected</em> and will cause primitive file operations fail. </p></note> - <warning><p> - Currently null characters at the end of the filename - will be accepted by primitive file operations. Such - filenames are however still documented as invalid. The - implementation will also change in the future and - reject such filenames. - </p></warning> </description> @@ -1438,8 +1434,12 @@ f.txt: {person, "kalle", 25}. which is 1970-01-01 00:00 UTC.</p></item> </taglist> <p>Default is <c>{time, local}</c>.</p> - <p>If the option <c>raw</c> is set, the file server is not called - and only information about local files is returned.</p> + <p>If the option <c>raw</c> is set, the file server is not called and + only information about local files is returned. Note that this will + break this module's atomicity guarantees as it can race with a + concurrent call to + <seealso marker="#write_file_info/2"><c>write_file_info/1,2</c> + </seealso></p> <note> <p>As file times are stored in POSIX time on most OS, it is faster to query file information with option <c>posix</c>.</p> @@ -1687,8 +1687,12 @@ f.txt: {person, "kalle", 25}. except that if <c><anno>Name</anno></c> is a symbolic link, information about the link is returned in the <c>file_info</c> record and the <c>type</c> field of the record is set to <c>symlink</c>.</p> - <p>If the option <c>raw</c> is set, the file server is not called - and only information about local files is returned.</p> + <p>If the option <c>raw</c> is set, the file server is not called and + only information about local files is returned. Note that this will + break this module's atomicity guarantees as it can race with a + concurrent call to + <seealso marker="#write_file_info/2"><c>write_file_info/1,2</c> + </seealso></p> <p>If <c><anno>Name</anno></c> is not a symbolic link, this function returns the same result as <c>read_file_info/1</c>. On platforms that do not support symbolic links, this function @@ -1826,24 +1830,16 @@ f.txt: {person, "kalle", 25}. <p>The file used must be opened using the <c>raw</c> flag, and the process calling <c>sendfile</c> must be the controlling process of the socket. See <seealso marker="gen_tcp#controlling_process-2"><c>gen_tcp:controlling_process/2</c></seealso>.</p> - <p>If the OS used does not support <c>sendfile</c>, an Erlang fallback - using - <seealso marker="#read/2"><c>read/2</c></seealso> and - <seealso marker="gen_tcp#send/2"><c>gen_tcp:send/2</c></seealso> is used.</p> + <p>If the OS used does not support non-blocking <c>sendfile</c>, an + Erlang fallback using <seealso marker="#read/2"><c>read/2</c></seealso> + and <seealso marker="gen_tcp#send/2"><c>gen_tcp:send/2</c></seealso> is + used.</p> <p>The option list can contain the following options:</p> <taglist> <tag><c>chunk_size</c></tag> <item><p>The chunk size used by the Erlang fallback to send data. If using the fallback, set this to a value that comfortably fits in the systems memory. Default is 20 MB.</p></item> - <tag><c>use_threads</c></tag> - <item><p>Instructs the emulator to use the <c>async</c> thread pool for the - <c>sendfile</c> system call. This can be useful if the OS you are running - on does not properly support non-blocking <c>sendfile</c> calls. Notice that - using <c>async</c> threads potentially makes your system vulnerable to slow - client attacks. If set to <c>true</c> and no <c>async</c> threads are available, - the <c>sendfile</c> call returns <c>{error,einval}</c>. - Introduced in Erlang/OTP 17.0. Default is <c>false</c>.</p></item> </taglist> </desc> </func> @@ -2148,144 +2144,77 @@ f.txt: {person, "kalle", 25}. <section> <title>Performance</title> - <p>Some operating system file operations, for example, a - <c>sync/1</c> or <c>close/1</c> on a huge file, can block their - calling thread for seconds. If this affects the emulator main - thread, the response time is no longer in the order of - milliseconds, depending on the definition of "soft" in soft - real-time system.</p> - <p>If the device driver thread pool is active, file operations are - done through those threads instead, so the emulator can go on - executing Erlang processes. Unfortunately, the time for serving a - file operation increases because of the extra scheduling required - from the operating system.</p> - <p>If the device driver thread pool is disabled or of size 0, large - file reads and writes are segmented into many smaller, which - enable the emulator to serve other processes during the file - operation. This has the same effect as when using the thread - pool, but with larger overhead. Other file operations, for - example, <c>sync/1</c> or <c>close/1</c> on a huge file, still are - a problem.</p> - <p>For increased performance, raw files are recommended. Raw files - use the file system of the host machine of the node.</p> + <p>For increased performance, raw files are recommended.</p> + <p>A normal file is really a process so it can be used as an I/O + device (see <seealso marker="stdlib:io"><c>io</c></seealso>). + Therefore, when data is written to a normal file, the sending of the + data to the file process, copies all data that are not binaries. Opening + the file in binary mode and writing binaries is therefore recommended. + If the file is opened on another node, or if the file server runs as + slave to the file server of another node, also binaries are copied.</p> <note> - <p> - For normal files (non-raw), the file server is used to find the files, - and if the node is running its file server as slave to the file server - of another node, and the other node runs on some other host machine, - they can have different file systems. - However, this is seldom a problem.</p> + <p>Raw files use the file system of the host machine of the node. + For normal files (non-raw), the file server is used to find the files, + and if the node is running its file server as slave to the file server + of another node, and the other node runs on some other host machine, + they can have different file systems. + However, this is seldom a problem.</p> </note> - <p>A normal file is really a process so it can be used as an I/O - device (see - <seealso marker="stdlib:io"><c>io</c></seealso>). - Therefore, when data is written to a - normal file, the sending of the data to the file process, copies - all data that are not binaries. Opening the file in binary mode - and writing binaries is therefore recommended. If the file is - opened on another node, or if the file server runs as slave to - the file server of another node, also binaries are copied.</p> - <p>Caching data to reduce the number of file operations, or rather - the number of calls to the file driver, generally increases - performance. The following function writes 4 MBytes in 23 - seconds when tested:</p> + <p><seealso marker="#open/2"><c>open/2</c></seealso> can be given the + options <c>delayed_write</c> and <c>read_ahead</c> to turn on caching, + which will reduce the number of operating system calls and greatly + improve performance for small reads and writes. However, the overhead + won't disappear completely and it's best to keep the number of file + operations to a minimum. As a contrived example, the following function + writes 4MB in 2.5 seconds when tested:</p> + <code type="none"><![CDATA[ -create_file_slow(Name, N) when integer(N), N >= 0 -> - {ok, FD} = file:open(Name, [raw, write, delayed_write, binary]), - ok = create_file_slow(FD, 0, N), - ok = ?FILE_MODULE:close(FD), - ok. - -create_file_slow(FD, M, M) -> +create_file_slow(Name) -> + {ok, Fd} = file:open(Name, [raw, write, delayed_write, binary]), + create_file_slow_1(Fd, 4 bsl 20), + file:close(Fd). + +create_file_slow_1(_Fd, 0) -> ok; -create_file_slow(FD, M, N) -> - ok = file:write(FD, <<M:32/unsigned>>), - create_file_slow(FD, M+1, N).]]></code> +create_file_slow_1(Fd, M) -> + ok = file:write(Fd, <<0>>), + create_file_slow_1(Fd, M - 1).]]></code> + + <p>The following functionally equivalent code writes 128 bytes per call + to <seealso marker="#write/2"><c>write/2</c></seealso> and so does the + same work in 0.08 seconds, which is roughly 30 times faster:</p> - <p>The following, functionally equivalent, function collects 1024 - entries into a list of 128 32-byte binaries before each call to - <seealso marker="#write/2"><c>write/2</c></seealso> and so - does the same work in 0.52 seconds, - which is 44 times faster:</p> <code type="none"><![CDATA[ -create_file(Name, N) when integer(N), N >= 0 -> - {ok, FD} = file:open(Name, [raw, write, delayed_write, binary]), - ok = create_file(FD, 0, N), - ok = ?FILE_MODULE:close(FD), +create_file(Name) -> + {ok, Fd} = file:open(Name, [raw, write, delayed_write, binary]), + create_file_1(Fd, 4 bsl 20), + file:close(Fd), ok. - -create_file(FD, M, M) -> + +create_file_1(_Fd, 0) -> ok; -create_file(FD, M, N) when M + 1024 =< N -> - create_file(FD, M, M + 1024, []), - create_file(FD, M + 1024, N); -create_file(FD, M, N) -> - create_file(FD, M, N, []). - -create_file(FD, M, M, R) -> - ok = file:write(FD, R); -create_file(FD, M, N0, R) when M + 8 =< N0 -> - N1 = N0-1, N2 = N0-2, N3 = N0-3, N4 = N0-4, - N5 = N0-5, N6 = N0-6, N7 = N0-7, N8 = N0-8, - create_file(FD, M, N8, - [<<N8:32/unsigned, N7:32/unsigned, - N6:32/unsigned, N5:32/unsigned, - N4:32/unsigned, N3:32/unsigned, - N2:32/unsigned, N1:32/unsigned>> | R]); -create_file(FD, M, N0, R) -> - N1 = N0-1, - create_file(FD, M, N1, [<<N1:32/unsigned>> | R]).]]></code> +create_file_1(Fd, M) when M >= 128 -> + ok = file:write(Fd, <<0:(128)/unit:8>>), + create_file_1(Fd, M - 128); +create_file_1(Fd, M) -> + ok = file:write(Fd, <<0:(M)/unit:8>>), + create_file_1(Fd, M - 1).]]></code> - <note> - <p>Trust only your own benchmarks. If the list length in - <c>create_file/2</c> above is increased, it runs slightly - faster, but consumes more memory and causes more memory - fragmentation. How much this affects your application is - something that this simple benchmark cannot predict.</p> - <p>If the size of each binary is increased to 64 bytes, it - also runs slightly faster, but the code is then twice as clumsy. - In the current implementation, binaries larger than 64 bytes are - stored in memory common to all processes and not copied when - sent between processes, while these smaller binaries are stored - on the process heap and copied when sent like any other term.</p> - <p>So, with a binary size of 68 bytes, <c>create_file/2</c> runs - 30 percent slower than with 64 bytes, and causes much more - memory fragmentation. Notice that if the binaries were to be sent - between processes (for example, a non-raw file), the results - would probably be completely different.</p> - </note> - <p>A raw file is really a port. When writing data to a port, it is - efficient to write a list of binaries. It is not needed to - flatten a deep list before writing. On Unix hosts, scatter output, - which writes a set of buffers in one operation, is used when - possible. In this way <c>write(FD, [Bin1, Bin2 | Bin3])</c> - writes the contents of the binaries without copying the data - at all, except for perhaps deep down in the operating system - kernel.</p> - <p>For raw files, <c>pwrite/2</c> and <c>pread/2</c> are - efficiently implemented. The file driver is called only once for - the whole operation, and the list iteration is done in the file - driver.</p> - <p>The options <c>delayed_write</c> and <c>read_ahead</c> to - <seealso marker="#open/2"><c>open/2</c></seealso> - make the file driver cache data to reduce - the number of operating system calls. The function - <c>create_file/2</c> in the recent example takes 60 seconds - without option <c>delayed_write</c>, which is 2.6 - times slower.</p> - <p>As a bad example, <c>create_file_slow/2</c> - without options <c>raw</c>, <c>binary</c>, and <c>delayed_write</c>, - meaning it calls <c>open(Name, [write])</c>, needs - 1 min 20 seconds for the job, which is 3.5 times slower than - the first example, and 150 times slower than the optimized - <c>create_file/2</c>.</p> - <warning> - <p>If an error occurs when accessing an open file with module - <seealso marker="stdlib:io"><c>io</c></seealso>, - the process handling the file exits. The dead - file process can hang if a process tries to access it later. - This will be fixed in a future release.</p> - </warning> + <p>When writing data it's generally more efficient to write a list of + binaries rather than a list of integers. It is not needed to + flatten a deep list before writing. On Unix hosts, scatter output, + which writes a set of buffers in one operation, is used when + possible. In this way <c>write(FD, [Bin1, Bin2 | Bin3])</c> + writes the contents of the binaries without copying the data + at all, except for perhaps deep down in the operating system + kernel.</p> + <warning> + <p>If an error occurs when accessing an open file with module + <seealso marker="stdlib:io"><c>io</c></seealso>, the process + handling the file exits. The dead file process can hang if a process + tries to access it later. This will be fixed in a future release. + </p> + </warning> </section> <section> diff --git a/lib/kernel/doc/src/gen_tcp.xml b/lib/kernel/doc/src/gen_tcp.xml index 070782e1f3..e6104b0c76 100644 --- a/lib/kernel/doc/src/gen_tcp.xml +++ b/lib/kernel/doc/src/gen_tcp.xml @@ -51,6 +51,7 @@ server() -> {ok, Sock} = gen_tcp:accept(LSock), {ok, Bin} = do_recv(Sock, []), ok = gen_tcp:close(Sock), + ok = gen_tcp:close(LSock), Bin. do_recv(Sock, Bs) -> @@ -309,9 +310,9 @@ do_recv(Sock, Bs) -> <seealso marker="inet#setopts/2"><c>inet:setopts/2</c></seealso>. </p></item> </taglist> - <p>The returned socket <c><anno>ListenSocket</anno></c> can only be - used in calls to - <seealso marker="#accept/1"><c>accept/1,2</c></seealso>.</p> + <p>The returned socket <c><anno>ListenSocket</anno></c> should be used + in calls to <seealso marker="#accept/1"><c>accept/1,2</c></seealso> to + accept incoming connection requests.</p> <note> <p>The default values for options specified to <c>listen</c> can be affected by the Kernel configuration parameter diff --git a/lib/kernel/doc/src/inet.xml b/lib/kernel/doc/src/inet.xml index 169a76463b..abb045b744 100644 --- a/lib/kernel/doc/src/inet.xml +++ b/lib/kernel/doc/src/inet.xml @@ -197,6 +197,9 @@ fe80::204:acff:fe17:bf38 <datatype> <name name="address_family"/> </datatype> + <datatype> + <name name="socket_protocol"/> + </datatype> </datatypes> <funcs> @@ -461,6 +464,61 @@ get_tcpi_sacked(Sock) -> </func> <func> + <name name="i" arity="0" /> + <name name="i" arity="1" /> + <name name="i" arity="2" /> + <fsummary>Displays information and statistics about sockets on the terminal</fsummary> + <desc> + <p> + Lists all TCP, UDP and SCTP sockets, including those that the Erlang runtime system uses as well as + those created by the application. + </p> + <p> + The following options are available: + </p> + + <taglist> + <tag><c>port</c></tag> + <item> + <p>The internal index of the port.</p> + </item> + <tag><c>module</c></tag> + <item> + <p>The callback module of the socket.</p> + </item> + <tag><c>recv</c></tag> + <item> + <p>Number of bytes received by the socket.</p> + </item> + <tag><c>sent</c></tag> + <item> + <p>Number of bytes sent from the socket.</p> + </item> + <tag><c>owner</c></tag> + <item> + <p>The socket owner process.</p> + </item> + <tag><c>local_address</c></tag> + <item> + <p>The local address of the socket.</p> + </item> + <tag><c>foreign_address</c></tag> + <item> + <p>The address and port of the other end of the connection.</p> + </item> + <tag><c>state</c></tag> + <item> + <p>The connection state.</p> + </item> + <tag><c>type</c></tag> + <item> + <p>STREAM or DGRAM or SEQPACKET.</p> + </item> + </taglist> + </desc> + </func> + + <func> <name name="ntoa" arity="1" /> <fsummary>Convert IPv6/IPV4 address to ASCII.</fsummary> <desc> @@ -1214,7 +1272,7 @@ inet:setopts(Sock,[{raw,6,8,<<30:32/native>>}]),]]></code> For one-to-many style sockets, the special value <c>0</c> is defined to mean that the returned addresses must be without any particular association. - How different SCTP implementations interprets this varies somewhat. + How different SCTP implementations interpret this varies somewhat. </p> </desc> </func> diff --git a/lib/kernel/doc/src/kernel_app.xml b/lib/kernel/doc/src/kernel_app.xml index e5ac031539..0762cebc94 100644 --- a/lib/kernel/doc/src/kernel_app.xml +++ b/lib/kernel/doc/src/kernel_app.xml @@ -4,7 +4,7 @@ <appref> <header> <copyright> - <year>1996</year><year>2017</year> + <year>1996</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -469,8 +469,12 @@ MaxT = TickTime + TickTime / 4</code> <item><c>ObjSuffix = string()</c></item> <item><c>SrcSuffix = string()</c></item> </list> - <p>Specifies a list of rules for use by <c>filelib:find_file/2</c> and - <c>filelib:find_source/2</c>. If this is set to some other value + <p>Specifies a list of rules for use by + <seealso marker="stdlib:filelib#find_file/2"> + <c>filelib:find_file/2</c></seealso> + <seealso marker="stdlib:filelib#find_source/2"> + <c>filelib:find_source/2</c></seealso> + If this is set to some other value than the empty list, it replaces the default rules. Rules can be simple pairs of directory suffixes, such as <c>{"ebin", "src"}</c>, which are used by <c>filelib:find_file/2</c>, or @@ -478,6 +482,16 @@ MaxT = TickTime + TickTime / 4</code> file name extensions, for example <c>[{".beam", ".erl", [{"ebin", "src"}]}</c>, which are used by <c>filelib:find_source/2</c>. Both kinds of rules can be mixed in the list.</p> + <p>The interpretation of <c>ObjDirSuffix</c> and <c>SrcDirSuffix</c> + is as follows: if the end of the directory name where an + object is located matches <c>ObjDirSuffix</c>, then the + name created by replacing <c>ObjDirSuffix</c> with + <c>SrcDirSuffix</c> is expanded by calling + <seealso marker="stdlib:filelib#wildcard/1"> + <c>filelib:wildcard/1</c></seealso>, and the first regular + file found among the matches is the source file. + </p> + </item> </taglist> </section> diff --git a/lib/kernel/doc/src/net_kernel.xml b/lib/kernel/doc/src/net_kernel.xml index 0b94fc0fa6..a30d28d55a 100644 --- a/lib/kernel/doc/src/net_kernel.xml +++ b/lib/kernel/doc/src/net_kernel.xml @@ -56,7 +56,7 @@ $ <input>erl -sname foobar</input></pre> <p>Normally, connections are established automatically when another node is referenced. This functionality can be disabled by setting Kernel configuration parameter - <c>dist_auto_connect</c> to <c>false</c>, see + <c>dist_auto_connect</c> to <c>never</c>, see <seealso marker="kernel_app"><c>kernel(6)</c></seealso>. In this case, connections must be established explicitly by calling <seealso marker="#connect_node/1"><c>connect_node/1</c></seealso>.</p> @@ -230,7 +230,12 @@ $ <input>erl -sname foobar</input></pre> <item> <p>The tuple <c>{nodedown_reason, Reason}</c> is included in <c>InfoList</c> in <c>nodedown</c> messages.</p> - <p><c>Reason</c> can be any of the following:</p> + <p> + <c>Reason</c> can, depending on which + distribution module or process that is used be any term, + but for the standard TCP distribution module it is + any of the following: + </p> <taglist> <tag><c>connection_setup_failed</c></tag> <item><p>The connection setup failed (after <c>nodeup</c> diff --git a/lib/kernel/doc/src/notes.xml b/lib/kernel/doc/src/notes.xml index a5316dd476..d7f224c38e 100644 --- a/lib/kernel/doc/src/notes.xml +++ b/lib/kernel/doc/src/notes.xml @@ -31,6 +31,21 @@ </header> <p>This document describes the changes made to the Kernel application.</p> +<section><title>Kernel 5.4.1</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Refactored an internal API.</p> + <p> + Own Id: OTP-14784</p> + </item> + </list> + </section> + +</section> + <section><title>Kernel 5.4</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/kernel/doc/src/os.xml b/lib/kernel/doc/src/os.xml index 0a08e2c78a..c27182ff0b 100644 --- a/lib/kernel/doc/src/os.xml +++ b/lib/kernel/doc/src/os.xml @@ -58,17 +58,6 @@ operations to fail. </p> </note> - <warning> - <p> - Currently null characters at the end of filenames, - environment variable names and values will be accepted - by the primitive operations. Such filenames, environment - variable names and values are however still documented as - invalid. The implementation will also change in the - future and reject such filenames, environment variable - names and values. - </p> - </warning> </description> <datatypes> @@ -143,12 +132,8 @@ <warning><p>Previous implementation used to allow all characters as long as they were integer values greater than or equal to zero. This sometimes lead to unwanted results since null characters - (integer value zero) often are interpreted as string termination. - Current implementation still accepts null characters at the end - of <c><anno>Command</anno></c> even though the documentation - states that no null characters are allowed. This will however - be changed in the future so that no null characters at all will - be accepted.</p></warning> + (integer value zero) often are interpreted as string termination. The + current implementation rejects these.</p></warning> <p><em>Examples:</em></p> <code type="none"> LsOut = os:cmd("ls"), % on unix platform diff --git a/lib/kernel/src/Makefile b/lib/kernel/src/Makefile index 5946620f0f..0bc9f121a0 100644 --- a/lib/kernel/src/Makefile +++ b/lib/kernel/src/Makefile @@ -106,6 +106,7 @@ MODULES = \ inet_sctp \ kernel \ kernel_config \ + kernel_refc \ local_udp \ local_tcp \ net \ @@ -120,6 +121,13 @@ MODULES = \ user \ user_drv \ user_sup \ + raw_file_io \ + raw_file_io_compressed \ + raw_file_io_inflate \ + raw_file_io_deflate \ + raw_file_io_delayed \ + raw_file_io_list \ + raw_file_io_raw \ wrap_log_reader HRL_FILES= ../include/file.hrl ../include/inet.hrl ../include/inet_sctp.hrl \ @@ -226,7 +234,8 @@ $(EBIN)/disk_log_server.beam: disk_log.hrl $(EBIN)/dist_util.beam: ../include/dist_util.hrl ../include/dist.hrl $(EBIN)/erl_boot_server.beam: inet_boot.hrl $(EBIN)/erl_epmd.beam: inet_int.hrl erl_epmd.hrl -$(EBIN)/file.beam: ../include/file.hrl +$(EBIN)/file.beam: ../include/file.hrl file_int.hrl +$(EBIN)/file_io_server.beam: ../include/file.hrl file_int.hrl $(EBIN)/gen_tcp.beam: inet_int.hrl $(EBIN)/gen_udp.beam: inet_int.hrl $(EBIN)/gen_sctp.beam: ../include/inet_sctp.hrl @@ -254,3 +263,10 @@ $(EBIN)/net_kernel.beam: ../include/net_address.hrl $(EBIN)/os.beam: ../include/file.hrl $(EBIN)/ram_file.beam: ../include/file.hrl $(EBIN)/wrap_log_reader.beam: disk_log.hrl ../include/file.hrl +$(EBIN)/raw_file_io.beam: ../include/file.hrl file_int.hrl +$(EBIN)/raw_file_io_compressed.beam: ../include/file.hrl file_int.hrl +$(EBIN)/raw_file_io_inflate.beam: ../include/file.hrl file_int.hrl +$(EBIN)/raw_file_io_deflate.beam: ../include/file.hrl file_int.hrl +$(EBIN)/raw_file_io_delayed.beam: ../include/file.hrl file_int.hrl +$(EBIN)/raw_file_io_list.beam: ../include/file.hrl file_int.hrl +$(EBIN)/raw_file_io_raw.beam: ../include/file.hrl file_int.hrl diff --git a/lib/kernel/src/disk_log.erl b/lib/kernel/src/disk_log.erl index 70cbf1c87c..99ea8dc384 100644 --- a/lib/kernel/src/disk_log.erl +++ b/lib/kernel/src/disk_log.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2017. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. @@ -266,7 +266,7 @@ inc_wrap_file(Log) -> Size :: dlog_size(), Reason :: no_such_log | nonode | {read_only_mode, Log} | {blocked_log, Log} - | {new_size_too_small, CurrentSize :: pos_integer()} + | {new_size_too_small, Log, CurrentSize :: pos_integer()} | {badarg, size} | {file_error, file:filename(), file_error()}. change_size(Log, NewSize) -> diff --git a/lib/kernel/src/dist_util.erl b/lib/kernel/src/dist_util.erl index 08bd5946cd..fb9f7fd7eb 100644 --- a/lib/kernel/src/dist_util.erl +++ b/lib/kernel/src/dist_util.erl @@ -250,7 +250,8 @@ check_dflags(#hs_data{other_node = Node, require_flags = RequiredFlags} = HSData) -> Mandatory = ((?DFLAG_EXTENDED_REFERENCES bor ?DFLAG_EXTENDED_PIDS_PORTS - bor ?DFLAG_UTF8_ATOMS) + bor ?DFLAG_UTF8_ATOMS + bor ?DFLAG_NEW_FUN_TAGS) bor RequiredFlags), Missing = check_mandatory(0, ?DFLAGS_ALL, Mandatory, OtherFlags, []), diff --git a/lib/kernel/src/erl_boot_server.erl b/lib/kernel/src/erl_boot_server.erl index 2a38266579..4ac945ce01 100644 --- a/lib/kernel/src/erl_boot_server.erl +++ b/lib/kernel/src/erl_boot_server.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -58,13 +58,11 @@ -define(single_addr_mask, {255, 255, 255, 255}). --type ip4_address() :: {0..255,0..255,0..255,0..255}. - --spec start(Slaves) -> {'ok', Pid} | {'error', What} when +-spec start(Slaves) -> {'ok', Pid} | {'error', Reason} when Slaves :: [Host], - Host :: atom(), + Host :: inet:ip_address() | inet:hostname(), Pid :: pid(), - What :: any(). + Reason :: {'badarg', Slaves}. start(Slaves) -> case check_arg(Slaves) of @@ -74,11 +72,11 @@ start(Slaves) -> {error, {badarg, Slaves}} end. --spec start_link(Slaves) -> {'ok', Pid} | {'error', What} when +-spec start_link(Slaves) -> {'ok', Pid} | {'error', Reason} when Slaves :: [Host], - Host :: atom(), + Host :: inet:ip_address() | inet:hostname(), Pid :: pid(), - What :: any(). + Reason :: {'badarg', Slaves}. start_link(Slaves) -> case check_arg(Slaves) of @@ -104,10 +102,10 @@ check_arg([], Result) -> check_arg(_, _Result) -> error. --spec add_slave(Slave) -> 'ok' | {'error', What} when +-spec add_slave(Slave) -> 'ok' | {'error', Reason} when Slave :: Host, - Host :: atom(), - What :: any(). + Host :: inet:ip_address() | inet:hostname(), + Reason :: {'badarg', Slave}. add_slave(Slave) -> case inet:getaddr(Slave, inet) of @@ -117,10 +115,10 @@ add_slave(Slave) -> {error, {badarg, Slave}} end. --spec delete_slave(Slave) -> 'ok' | {'error', What} when +-spec delete_slave(Slave) -> 'ok' | {'error', Reason} when Slave :: Host, - Host :: atom(), - What :: any(). + Host :: inet:ip_address() | inet:hostname(), + Reason :: {'badarg', Slave}. delete_slave(Slave) -> case inet:getaddr(Slave, inet) of @@ -130,7 +128,7 @@ delete_slave(Slave) -> {error, {badarg, Slave}} end. --spec add_subnet(Mask :: ip4_address(), Addr :: ip4_address()) -> +-spec add_subnet(Netmask :: inet:ip_address(), Addr :: inet:ip_address()) -> 'ok' | {'error', any()}. add_subnet(Mask, Addr) when is_tuple(Mask), is_tuple(Addr) -> @@ -141,14 +139,15 @@ add_subnet(Mask, Addr) when is_tuple(Mask), is_tuple(Addr) -> {error, empty_subnet} end. --spec delete_subnet(Mask :: ip4_address(), Addr :: ip4_address()) -> 'ok'. +-spec delete_subnet(Netmask :: inet:ip_address(), + Addr :: inet:ip_address()) -> 'ok'. delete_subnet(Mask, Addr) when is_tuple(Mask), is_tuple(Addr) -> gen_server:call(boot_server, {delete, {Mask, Addr}}). -spec which_slaves() -> Slaves when - Slaves :: [Host], - Host :: atom(). + Slaves :: [Slave], + Slave :: {Netmask :: inet:ip_address(), Address :: inet:ip_address()}. which_slaves() -> gen_server:call(boot_server, which). diff --git a/lib/kernel/src/erts_debug.erl b/lib/kernel/src/erts_debug.erl index 2887014c1c..3456c8511e 100644 --- a/lib/kernel/src/erts_debug.erl +++ b/lib/kernel/src/erts_debug.erl @@ -21,7 +21,7 @@ %% Low-level debugging support. EXPERIMENTAL! --export([size/1,df/1,df/2,df/3,ic/1]). +-export([size/1,df/1,df/2,df/3,dis_to_file/2,ic/1]). %% This module contains the following *experimental* BIFs: %% disassemble/1 @@ -378,6 +378,16 @@ df(Mod, Func, Arity) when is_atom(Mod), is_atom(Func) -> catch _:_ -> {undef,Mod} end. +-spec dis_to_file(module(), file:filename()) -> df_ret(). + +dis_to_file(Mod, Name) when is_atom(Mod) -> + try Mod:module_info(functions) of + Fs0 when is_list(Fs0) -> + Fs = [{Mod,Func,Arity} || {Func,Arity} <- Fs0], + dff(Name, Fs) + catch _:_ -> {undef,Mod} + end. + dff(Name, Fs) -> case file:open(Name, [write,raw,delayed_write]) of {ok,F} -> diff --git a/lib/kernel/src/file.erl b/lib/kernel/src/file.erl index 933f2d5f65..d05199897f 100644 --- a/lib/kernel/src/file.erl +++ b/lib/kernel/src/file.erl @@ -72,7 +72,7 @@ io_device/0, name/0, name_all/0, posix/0]). %%% Includes and defines --include("file.hrl"). +-include("file_int.hrl"). -define(FILE_IO_SERVER_TABLE, file_io_servers). @@ -454,41 +454,23 @@ raw_write_file_info(Name, #file_info{} = Info) -> Reason :: posix() | badarg | system_limit. open(Item, ModeList) when is_list(ModeList) -> - case lists:member(raw, ModeList) of - %% Raw file, use ?PRIM_FILE to handle this file - true -> + case {lists:member(raw, ModeList), lists:member(ram, ModeList)} of + {false, false} -> + %% File server file Args = [file_name(Item) | ModeList], case check_args(Args) of ok -> [FileName | _] = Args, - %% We rely on the returned Handle (in {ok, Handle}) - %% being a pid() or a #file_descriptor{} - ?PRIM_FILE:open(FileName, ModeList); + call(open, [FileName, ModeList]); Error -> Error - end; - false -> - case lists:member(ram, ModeList) of - %% RAM file, use ?RAM_FILE to handle this file - true -> - case check_args(ModeList) of - ok -> - ?RAM_FILE:open(Item, ModeList); - Error -> - Error - end; - %% File server file - false -> - Args = [file_name(Item) | ModeList], - case check_args(Args) of - ok -> - [FileName | _] = Args, - call(open, [FileName, ModeList]); - Error -> - Error - end - end + end; + {true, _Either} -> + raw_file_io:open(file_name(Item), ModeList); + {false, true} -> + ram_file:open(Item, ModeList) end; + %% Old obsolete mode specification in atom or 2-tuple format open(Item, Mode) -> open(Item, mode_list(Mode)). @@ -1254,15 +1236,18 @@ sendfile(File, _Sock, _Offet, _Bytes, _Opts) when is_pid(File) -> sendfile(File, Sock, Offset, Bytes, []) -> sendfile(File, Sock, Offset, Bytes, ?MAX_CHUNK_SIZE, [], [], []); sendfile(File, Sock, Offset, Bytes, Opts) -> - ChunkSize0 = proplists:get_value(chunk_size, Opts, ?MAX_CHUNK_SIZE), - ChunkSize = if ChunkSize0 > ?MAX_CHUNK_SIZE -> - ?MAX_CHUNK_SIZE; - true -> ChunkSize0 - end, - %% Support for headers, trailers and options has been removed because the - %% Darwin and BSD API for using it does not play nice with - %% non-blocking sockets. See unix_efile.c for more info. - sendfile(File, Sock, Offset, Bytes, ChunkSize, [], [], Opts). + try proplists:get_value(chunk_size, Opts, ?MAX_CHUNK_SIZE) of + ChunkSize0 when is_integer(ChunkSize0) -> + ChunkSize = erlang:min(ChunkSize0, ?MAX_CHUNK_SIZE), + %% Support for headers, trailers and options has been removed + %% because the Darwin and BSD API for using it does not play nice + %% with non-blocking sockets. See unix_efile.c for more info. + sendfile(File, Sock, Offset, Bytes, ChunkSize, [], [], Opts); + _Other -> + {error, badarg} + catch + error:_ -> {error, badarg} + end. %% sendfile/2 -spec sendfile(Filename, Socket) -> diff --git a/lib/compiler/src/v3_life.hrl b/lib/kernel/src/file_int.hrl index 5c76312067..bafc330c04 100644 --- a/lib/compiler/src/v3_life.hrl +++ b/lib/kernel/src/file_int.hrl @@ -1,8 +1,8 @@ %% %% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1999-2016. All Rights Reserved. -%% +%% +%% Copyright Ericsson AB 2017. 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 @@ -14,16 +14,20 @@ %% 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% %% -%% This record contains variable life-time annotation for a -%% kernel expression. Added by v3_life, used by v3_codegen. --type vdb_entry() :: {atom(),non_neg_integer(),non_neg_integer()}. +%% +%% Internal definitions for the 'file' module and friends. +%% + +-ifndef(FILE_INTERNAL_HRL_). +-define(FILE_INTERNAL_HRL_, 1). + +-include("file.hrl"). --record(l, {ke, %Kernel expression - i=0 :: non_neg_integer(), %Op number - vdb=[] :: [vdb_entry()], %Variable database - a=[] :: [term()]}). %Core annotation +-define(CALL_FD(Fd, Method, Args), + apply(Fd#file_descriptor.module, Method, [Fd | Args])). +-endif. diff --git a/lib/kernel/src/file_io_server.erl b/lib/kernel/src/file_io_server.erl index deb7b315b1..34d5497a4a 100644 --- a/lib/kernel/src/file_io_server.erl +++ b/lib/kernel/src/file_io_server.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2000-2015. All Rights Reserved. +%% Copyright Ericsson AB 2000-2017. 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. @@ -28,7 +28,8 @@ -record(state, {handle,owner,mref,buf,read_mode,unic}). --define(PRIM_FILE, prim_file). +-include("file_int.hrl"). + -define(READ_SIZE_LIST, 128). -define(READ_SIZE_BINARY, (8*1024)). @@ -67,8 +68,9 @@ do_start(Spawn, Owner, FileName, ModeList) -> erlang:dt_restore_tag(Utag), %% process_flag(trap_exit, true), case parse_options(ModeList) of - {ReadMode, UnicodeMode, Opts} -> - case ?PRIM_FILE:open(FileName, Opts) of + {ReadMode, UnicodeMode, Opts0} -> + Opts = maybe_add_read_ahead(ReadMode, Opts0), + case raw_file_io:open(FileName, [raw | Opts]) of {error, Reason} = Error -> Self ! {Ref, Error}, exit(Reason); @@ -157,6 +159,24 @@ valid_enc({utf32,little}) -> valid_enc(_Other) -> {error,badarg}. +%% Add a small read_ahead buffer if the file is opened for reading +%% only in list mode and no read_ahead is already given. +maybe_add_read_ahead(binary, Opts) -> + Opts; +maybe_add_read_ahead(list, Opts) -> + P = fun(read_ahead) -> true; + ({read_ahead,_}) -> true; + (append) -> true; + (exclusive) -> true; + (write) -> true; + (_) -> false + end, + case lists:any(P, Opts) of + false -> + [{read_ahead, 4096}|Opts]; + true -> + Opts + end. server_loop(#state{mref = Mref} = State) -> receive @@ -205,7 +225,7 @@ io_reply(From, ReplyAs, Reply) -> file_request({advise,Offset,Length,Advise}, #state{handle=Handle}=State) -> - case ?PRIM_FILE:advise(Handle, Offset, Length, Advise) of + case ?CALL_FD(Handle, advise, [Offset, Length, Advise]) of {error,Reason}=Reply -> {stop,Reason,Reply,State}; Reply -> @@ -213,7 +233,7 @@ file_request({advise,Offset,Length,Advise}, end; file_request({allocate, Offset, Length}, #state{handle = Handle} = State) -> - Reply = ?PRIM_FILE:allocate(Handle, Offset, Length), + Reply = ?CALL_FD(Handle, allocate, [Offset, Length]), {reply, Reply, State}; file_request({pread,At,Sz}, State) when At =:= cur; @@ -256,7 +276,7 @@ file_request({pwrite,At,Data}, end; file_request(datasync, #state{handle=Handle}=State) -> - case ?PRIM_FILE:datasync(Handle) of + case ?CALL_FD(Handle, datasync, []) of {error,Reason}=Reply -> {stop,Reason,Reply,State}; Reply -> @@ -264,7 +284,7 @@ file_request(datasync, end; file_request(sync, #state{handle=Handle}=State) -> - case ?PRIM_FILE:sync(Handle) of + case ?CALL_FD(Handle, sync, []) of {error,Reason}=Reply -> {stop,Reason,Reply,State}; Reply -> @@ -272,7 +292,7 @@ file_request(sync, end; file_request(close, #state{handle=Handle}=State) -> - case ?PRIM_FILE:close(Handle) of + case ?CALL_FD(Handle, close, []) of {error,Reason}=Reply -> {stop,Reason,Reply,State#state{buf= <<>>}}; Reply -> @@ -288,7 +308,7 @@ file_request({position,At}, end; file_request(truncate, #state{handle=Handle}=State) -> - case ?PRIM_FILE:truncate(Handle) of + case ?CALL_FD(Handle, truncate, []) of {error,Reason}=Reply -> {stop,Reason,Reply,State#state{buf= <<>>}}; Reply -> @@ -398,7 +418,7 @@ io_request_loop([Request|Tail], %% put_chars(Chars, latin1, #state{handle=Handle, unic=latin1}=State) -> NewState = State#state{buf = <<>>}, - case ?PRIM_FILE:write(Handle, Chars) of + case ?CALL_FD(Handle, write, [Chars]) of {error,Reason}=Reply -> {stop,Reason,Reply,NewState}; Reply -> @@ -408,7 +428,7 @@ put_chars(Chars, InEncoding, #state{handle=Handle, unic=OutEncoding}=State) -> NewState = State#state{buf = <<>>}, case unicode:characters_to_binary(Chars,InEncoding,OutEncoding) of Bin when is_binary(Bin) -> - case ?PRIM_FILE:write(Handle, Bin) of + case ?CALL_FD(Handle, write, [Bin]) of {error,Reason}=Reply -> {stop,Reason,Reply,NewState}; Reply -> @@ -422,7 +442,7 @@ put_chars(Chars, InEncoding, #state{handle=Handle, unic=OutEncoding}=State) -> get_line(S, {<<>>, Cont}, OutEnc, #state{handle=Handle, read_mode=Mode, unic=InEnc}=State) -> - case ?PRIM_FILE:read(Handle, read_size(Mode)) of + case ?CALL_FD(Handle, read, [read_size(Mode)]) of {ok,Bin} -> get_line(S, convert_enc([Cont, Bin], InEnc, OutEnc), OutEnc, State); eof -> @@ -472,7 +492,7 @@ get_chars(N, OutEnc,#state{handle=Handle,buf=Buf,read_mode=ReadMode,unic=latin1} BufSize = byte_size(Buf), NeedSize = N-BufSize, Size = erlang:max(NeedSize, ?READ_SIZE_BINARY), - case ?PRIM_FILE:read(Handle, Size) of + case ?CALL_FD(Handle, read, [Size]) of {ok, B} -> if BufSize+byte_size(B) < N -> std_reply(cat(Buf, B, ReadMode,latin1,OutEnc), State); @@ -504,7 +524,7 @@ get_chars(N, OutEnc,#state{handle=Handle,buf=Buf,read_mode=ReadMode,unic=InEncod %% Need more, Try to read 4*needed in bytes... NeedSize = (N - BufCount) * 4, Size = erlang:max(NeedSize, ?READ_SIZE_BINARY), - case ?PRIM_FILE:read(Handle, Size) of + case ?CALL_FD(Handle, read, [Size]) of {ok, B} -> NewBuf = list_to_binary([Buf,B]), {NewCount,NewSplit} = count_and_find(NewBuf,N,InEncoding), @@ -544,7 +564,7 @@ get_chars(Mod, Func, XtraArg, OutEnc, #state{buf=Buf}=State) -> get_chars_empty(Mod, Func, XtraArg, S, latin1, #state{handle=Handle,read_mode=ReadMode, unic=latin1}=State) -> - case ?PRIM_FILE:read(Handle, read_size(ReadMode)) of + case ?CALL_FD(Handle, read, [read_size(ReadMode)]) of {ok,Bin} -> get_chars_apply(Mod, Func, XtraArg, S, latin1, State, Bin); eof -> @@ -554,7 +574,7 @@ get_chars_empty(Mod, Func, XtraArg, S, latin1, end; get_chars_empty(Mod, Func, XtraArg, S, OutEnc, #state{handle=Handle,read_mode=ReadMode}=State) -> - case ?PRIM_FILE:read(Handle, read_size(ReadMode)) of + case ?CALL_FD(Handle, read, [read_size(ReadMode)]) of {ok,Bin} -> get_chars_apply(Mod, Func, XtraArg, S, OutEnc, State, Bin); eof -> @@ -564,7 +584,7 @@ get_chars_empty(Mod, Func, XtraArg, S, OutEnc, end. get_chars_notempty(Mod, Func, XtraArg, S, OutEnc, #state{handle=Handle,read_mode=ReadMode,buf = B}=State) -> - case ?PRIM_FILE:read(Handle, read_size(ReadMode)) of + case ?CALL_FD(Handle, read, [read_size(ReadMode)]) of {ok,Bin} -> get_chars_apply(Mod, Func, XtraArg, S, OutEnc, State, list_to_binary([B,Bin])); eof -> @@ -918,13 +938,10 @@ cbv({utf32,little},_) -> %% Compensates ?PRIM_FILE:position/2 for the number of bytes %% we have buffered position(Handle, At, Buf) -> - ?PRIM_FILE:position( - Handle, - case At of - cur -> - {cur, -byte_size(Buf)}; - {cur, Offs} -> - {cur, Offs-byte_size(Buf)}; - _ -> - At - end). + SeekTo = + case At of + {cur, Offs} -> {cur, Offs-byte_size(Buf)}; + cur -> {cur, -byte_size(Buf)}; + _ -> At + end, + ?CALL_FD(Handle, position, [SeekTo]). diff --git a/lib/kernel/src/file_server.erl b/lib/kernel/src/file_server.erl index 6e8f64d932..ecc1ffbdd6 100644 --- a/lib/kernel/src/file_server.erl +++ b/lib/kernel/src/file_server.erl @@ -63,7 +63,7 @@ stop() -> %%% Callback functions from gen_server %%%---------------------------------------------------------------------- --type state() :: port(). % Internal type +-type state() :: term(). % Internal type %%---------------------------------------------------------------------- %% Func: init/1 @@ -77,14 +77,8 @@ stop() -> init([]) -> process_flag(trap_exit, true), - case ?PRIM_FILE:start() of - {ok, Handle} -> - ?FILE_IO_SERVER_TABLE = - ets:new(?FILE_IO_SERVER_TABLE, [named_table]), - {ok, Handle}; - {error, Reason} -> - {stop, Reason} - end. + ?FILE_IO_SERVER_TABLE = ets:new(?FILE_IO_SERVER_TABLE, [named_table]), + {ok, undefined}. %%---------------------------------------------------------------------- %% Func: handle_call/3 @@ -101,7 +95,7 @@ init([]) -> {'reply', 'eof' | 'ok' | {'error', term()} | {'ok', term()}, state()} | {'stop', 'normal', 'stopped', state()}. -handle_call({open, Name, ModeList}, {Pid, _Tag} = _From, Handle) +handle_call({open, Name, ModeList}, {Pid, _Tag} = _From, State) when is_list(ModeList) -> Child = ?FILE_IO_SERVER:start_link(Pid, Name, ModeList), case Child of @@ -110,78 +104,78 @@ handle_call({open, Name, ModeList}, {Pid, _Tag} = _From, Handle) _ -> ok end, - {reply, Child, Handle}; + {reply, Child, State}; -handle_call({open, _Name, _Mode}, _From, Handle) -> - {reply, {error, einval}, Handle}; +handle_call({open, _Name, _Mode}, _From, State) -> + {reply, {error, einval}, State}; -handle_call({read_file, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:read_file(Name), Handle}; +handle_call({read_file, Name}, _From, State) -> + {reply, ?PRIM_FILE:read_file(Name), State}; -handle_call({write_file, Name, Bin}, _From, Handle) -> - {reply, ?PRIM_FILE:write_file(Name, Bin), Handle}; +handle_call({write_file, Name, Bin}, _From, State) -> + {reply, ?PRIM_FILE:write_file(Name, Bin), State}; -handle_call({set_cwd, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:set_cwd(Handle, Name), Handle}; +handle_call({set_cwd, Name}, _From, State) -> + {reply, ?PRIM_FILE:set_cwd(Name), State}; -handle_call({delete, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:delete(Handle, Name), Handle}; +handle_call({delete, Name}, _From, State) -> + {reply, ?PRIM_FILE:delete(Name), State}; -handle_call({rename, Fr, To}, _From, Handle) -> - {reply, ?PRIM_FILE:rename(Handle, Fr, To), Handle}; +handle_call({rename, Fr, To}, _From, State) -> + {reply, ?PRIM_FILE:rename(Fr, To), State}; -handle_call({make_dir, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:make_dir(Handle, Name), Handle}; +handle_call({make_dir, Name}, _From, State) -> + {reply, ?PRIM_FILE:make_dir(Name), State}; -handle_call({del_dir, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:del_dir(Handle, Name), Handle}; +handle_call({del_dir, Name}, _From, State) -> + {reply, ?PRIM_FILE:del_dir(Name), State}; -handle_call({list_dir, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:list_dir(Handle, Name), Handle}; -handle_call({list_dir_all, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:list_dir_all(Handle, Name), Handle}; +handle_call({list_dir, Name}, _From, State) -> + {reply, ?PRIM_FILE:list_dir(Name), State}; +handle_call({list_dir_all, Name}, _From, State) -> + {reply, ?PRIM_FILE:list_dir_all(Name), State}; -handle_call(get_cwd, _From, Handle) -> - {reply, ?PRIM_FILE:get_cwd(Handle), Handle}; -handle_call({get_cwd}, _From, Handle) -> - {reply, ?PRIM_FILE:get_cwd(Handle), Handle}; -handle_call({get_cwd, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:get_cwd(Handle, Name), Handle}; +handle_call(get_cwd, _From, State) -> + {reply, ?PRIM_FILE:get_cwd(), State}; +handle_call({get_cwd}, _From, State) -> + {reply, ?PRIM_FILE:get_cwd(), State}; +handle_call({get_cwd, Name}, _From, State) -> + {reply, ?PRIM_FILE:get_cwd(Name), State}; -handle_call({read_file_info, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:read_file_info(Handle, Name), Handle}; +handle_call({read_file_info, Name}, _From, State) -> + {reply, ?PRIM_FILE:read_file_info(Name), State}; -handle_call({read_file_info, Name, Opts}, _From, Handle) -> - {reply, ?PRIM_FILE:read_file_info(Handle, Name, Opts), Handle}; +handle_call({read_file_info, Name, Opts}, _From, State) -> + {reply, ?PRIM_FILE:read_file_info(Name, Opts), State}; -handle_call({altname, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:altname(Handle, Name), Handle}; +handle_call({altname, Name}, _From, State) -> + {reply, ?PRIM_FILE:altname(Name), State}; -handle_call({write_file_info, Name, Info}, _From, Handle) -> - {reply, ?PRIM_FILE:write_file_info(Handle, Name, Info), Handle}; +handle_call({write_file_info, Name, Info}, _From, State) -> + {reply, ?PRIM_FILE:write_file_info(Name, Info), State}; -handle_call({write_file_info, Name, Info, Opts}, _From, Handle) -> - {reply, ?PRIM_FILE:write_file_info(Handle, Name, Info, Opts), Handle}; +handle_call({write_file_info, Name, Info, Opts}, _From, State) -> + {reply, ?PRIM_FILE:write_file_info(Name, Info, Opts), State}; -handle_call({read_link_info, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:read_link_info(Handle, Name), Handle}; +handle_call({read_link_info, Name}, _From, State) -> + {reply, ?PRIM_FILE:read_link_info(Name), State}; -handle_call({read_link_info, Name, Opts}, _From, Handle) -> - {reply, ?PRIM_FILE:read_link_info(Handle, Name, Opts), Handle}; +handle_call({read_link_info, Name, Opts}, _From, State) -> + {reply, ?PRIM_FILE:read_link_info(Name, Opts), State}; -handle_call({read_link, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:read_link(Handle, Name), Handle}; -handle_call({read_link_all, Name}, _From, Handle) -> - {reply, ?PRIM_FILE:read_link_all(Handle, Name), Handle}; +handle_call({read_link, Name}, _From, State) -> + {reply, ?PRIM_FILE:read_link(Name), State}; +handle_call({read_link_all, Name}, _From, State) -> + {reply, ?PRIM_FILE:read_link_all(Name), State}; -handle_call({make_link, Old, New}, _From, Handle) -> - {reply, ?PRIM_FILE:make_link(Handle, Old, New), Handle}; +handle_call({make_link, Old, New}, _From, State) -> + {reply, ?PRIM_FILE:make_link(Old, New), State}; -handle_call({make_symlink, Old, New}, _From, Handle) -> - {reply, ?PRIM_FILE:make_symlink(Handle, Old, New), Handle}; +handle_call({make_symlink, Old, New}, _From, State) -> + {reply, ?PRIM_FILE:make_symlink(Old, New), State}; handle_call({copy, SourceName, SourceOpts, DestName, DestOpts, Length}, - _From, Handle) -> + _From, State) -> Reply = case ?PRIM_FILE:open(SourceName, [read, binary | SourceOpts]) of {ok, Source} -> @@ -201,14 +195,14 @@ handle_call({copy, SourceName, SourceOpts, DestName, DestOpts, Length}, {error, _} = Error -> Error end, - {reply, Reply, Handle}; + {reply, Reply, State}; -handle_call(stop, _From, Handle) -> - {stop, normal, stopped, Handle}; +handle_call(stop, _From, State) -> + {stop, normal, stopped, State}; -handle_call(Request, From, Handle) -> +handle_call(Request, From, State) -> error_logger:error_msg("handle_call(~tp, ~tp, _)", [Request, From]), - {noreply, Handle}. + {noreply, State}. %%---------------------------------------------------------------------- %% Func: handle_cast/2 @@ -233,14 +227,9 @@ handle_cast(Msg, State) -> -spec handle_info(term(), state()) -> {'noreply', state()} | {'stop', 'normal', state()}. -handle_info({'EXIT', Pid, _Reason}, Handle) when is_pid(Pid) -> +handle_info({'EXIT', Pid, _Reason}, State) when is_pid(Pid) -> ets:delete(?FILE_IO_SERVER_TABLE, Pid), - {noreply, Handle}; - -handle_info({'EXIT', Handle, _Reason}, Handle) -> - error_logger:error_msg("Port controlling ~w terminated in ~w", - [?FILE_SERVER, ?MODULE]), - {stop, normal, Handle}; + {noreply, State}; handle_info(Info, State) -> error_logger:error_msg("handle_Info(~tp, _)", [Info]), @@ -254,8 +243,8 @@ handle_info(Info, State) -> -spec terminate(term(), state()) -> 'ok'. -terminate(_Reason, Handle) -> - ?PRIM_FILE:stop(Handle). +terminate(_Reason, _State) -> + ok. %%---------------------------------------------------------------------- %% Func: code_change/3 diff --git a/lib/kernel/src/group_history.erl b/lib/kernel/src/group_history.erl index 91f3663cc5..9745848992 100644 --- a/lib/kernel/src/group_history.erl +++ b/lib/kernel/src/group_history.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2017. All Rights Reserved. +%% Copyright Ericsson AB 2017-2018. 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. @@ -260,7 +260,7 @@ resize_log(Name, _OldSize, NewSize) -> ok -> show('$#erlang-history-resize-result', "ok~n", []); - {error, {new_size_too_small, _}} -> + {error, {new_size_too_small, _, _}} -> show('$#erlang-history-resize-result', "failed (new size is too small)~n", []), disable_history(); diff --git a/lib/kernel/src/hipe_unified_loader.erl b/lib/kernel/src/hipe_unified_loader.erl index f4c7c277ed..fd06f0f7d8 100644 --- a/lib/kernel/src/hipe_unified_loader.erl +++ b/lib/kernel/src/hipe_unified_loader.erl @@ -236,9 +236,10 @@ load_common(Mod, Bin, Beam, Architecture) -> lists:foreach(fun({FE, DestAddress}) -> hipe_bifs:set_native_address_in_fe(FE, DestAddress) end, erase(closures_to_patch)), - ok = hipe_bifs:commit_patch_load(LoaderState), set_beam_call_traps(FunDefs), - ok; + export_funs(FunDefs), + ok = hipe_bifs:commit_patch_load(LoaderState), + ok; BeamBinary when is_binary(BeamBinary) -> %% Find all closures in the code. [] = erase(closures_to_patch), %Clean up, assertion. @@ -274,6 +275,7 @@ needs_trampolines(Architecture) -> arm -> true; powerpc -> true; ppc64 -> true; + amd64 -> true; _ -> false end. diff --git a/lib/kernel/src/inet.erl b/lib/kernel/src/inet.erl index dc20c21c77..fe91b0d33e 100644 --- a/lib/kernel/src/inet.erl +++ b/lib/kernel/src/inet.erl @@ -72,7 +72,7 @@ %% timer interface -export([start_timer/1, timeout/1, timeout/2, stop_timer/1]). --export_type([address_family/0, hostent/0, hostname/0, ip4_address/0, +-export_type([address_family/0, socket_protocol/0, hostent/0, hostname/0, ip4_address/0, ip6_address/0, ip_address/0, port_number/0, local_address/0, socket_address/0, returned_non_ip_address/0, socket_setopt/0, socket_getopt/0, @@ -1452,11 +1452,14 @@ fdopen(Fd, Addr, Port, Opts, Protocol, Family, Type, Module) -> %% socket stat %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-spec i() -> ok. i() -> i(tcp), i(udp), i(sctp). +-spec i(socket_protocol()) -> ok. i(Proto) -> i(Proto, [port, module, recv, sent, owner, local_address, foreign_address, state, type]). +-spec i(socket_protocol(), [atom()]) -> ok. i(tcp, Fs) -> ii(tcp_sockets(), Fs, tcp); i(udp, Fs) -> diff --git a/lib/kernel/src/inet_int.hrl b/lib/kernel/src/inet_int.hrl index bc5b67f7bf..357e27826c 100644 --- a/lib/kernel/src/inet_int.hrl +++ b/lib/kernel/src/inet_int.hrl @@ -100,6 +100,8 @@ -define(TCP_REQ_RECV, 42). -define(TCP_REQ_UNRECV, 43). -define(TCP_REQ_SHUTDOWN, 44). +-define(TCP_REQ_SENDFILE, 45). + %% UDP and SCTP requests -define(PACKET_REQ_RECV, 60). %%-define(SCTP_REQ_LISTEN, 61). MERGED @@ -319,6 +321,12 @@ [((X) bsr 24) band 16#ff, ((X) bsr 16) band 16#ff, ((X) bsr 8) band 16#ff, (X) band 16#ff]). +-define(int64(X), + [((X) bsr 56) band 16#ff, ((X) bsr 48) band 16#ff, + ((X) bsr 40) band 16#ff, ((X) bsr 32) band 16#ff, + ((X) bsr 24) band 16#ff, ((X) bsr 16) band 16#ff, + ((X) bsr 8) band 16#ff, (X) band 16#ff]). + -define(intAID(X), % For SCTP AssocID ?int32(X)). diff --git a/lib/kernel/src/kernel.app.src b/lib/kernel/src/kernel.app.src index 080b11fc4d..82a3571da9 100644 --- a/lib/kernel/src/kernel.app.src +++ b/lib/kernel/src/kernel.app.src @@ -57,6 +57,7 @@ inet_tcp_dist, kernel, kernel_config, + kernel_refc, local_tcp, local_udp, net, @@ -88,6 +89,13 @@ inet_udp, inet_sctp, pg2, + raw_file_io, + raw_file_io_compressed, + raw_file_io_deflate, + raw_file_io_delayed, + raw_file_io_inflate, + raw_file_io_list, + raw_file_io_raw, seq_trace, standard_error, wrap_log_reader]}, @@ -107,6 +115,7 @@ heart, init, kernel_config, + kernel_refc, kernel_sup, net_kernel, net_sup, diff --git a/lib/kernel/src/kernel.appup.src b/lib/kernel/src/kernel.appup.src index fc5417597f..4ee497bbbd 100644 --- a/lib/kernel/src/kernel.appup.src +++ b/lib/kernel/src/kernel.appup.src @@ -18,7 +18,9 @@ %% %CopyrightEnd% {"%VSN%", %% Up from - max one major revision back - [{<<"5\\.3(\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-20.* + [{<<"5\\.[0-3](\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-19.*, OTP-20.0 + {<<"5\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-20.1+ %% Down to - max one major revision back - [{<<"5\\.3(\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-20.* + [{<<"5\\.[0-3](\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-19.*, OTP-20.0 + {<<"5\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-20.1+ }. diff --git a/lib/kernel/src/kernel.erl b/lib/kernel/src/kernel.erl index cba57088ec..0382764b39 100644 --- a/lib/kernel/src/kernel.erl +++ b/lib/kernel/src/kernel.erl @@ -111,6 +111,13 @@ init([]) -> type => worker, modules => [kernel_config]}, + RefC = #{id => kernel_refc, + start => {kernel_refc, start_link, []}, + restart => permanent, + shutdown => 2000, + type => worker, + modules => [kernel_refc]}, + Code = #{id => code_server, start => {code, start_link, []}, restart => permanent, @@ -148,7 +155,7 @@ init([]) -> case init:get_argument(mode) of {ok, [["minimal"]]} -> - {ok, {SupFlags, [Code, File, StdError, User, Config, SafeSup]}}; + {ok, {SupFlags, [Code, File, StdError, User, Config, RefC, SafeSup]}}; _ -> Rpc = #{id => rex, start => {rpc, start_link, []}, @@ -199,7 +206,7 @@ init([]) -> {ok, {SupFlags, [Code, Rpc, Global, InetDb | DistAC] ++ [NetSup, GlGroup, File, SigSrv, - StdError, User, Config, SafeSup] ++ Timer}} + StdError, User, Config, RefC, SafeSup] ++ Timer}} end; init(safe) -> SupFlags = #{strategy => one_for_one, diff --git a/lib/kernel/src/kernel_refc.erl b/lib/kernel/src/kernel_refc.erl new file mode 100644 index 0000000000..05076dc885 --- /dev/null +++ b/lib/kernel/src/kernel_refc.erl @@ -0,0 +1,139 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. 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(kernel_refc). + +-behaviour(gen_server). + +%% External exports +-export([start_link/0, scheduler_wall_time/1]). +%% Internal exports +-export([init/1, handle_info/2, terminate/2]). +-export([handle_call/3, handle_cast/2, code_change/3]). + +%%%----------------------------------------------------------------- +%%% This module implements a process that handles reference counters for +%%% various erts or other kernel resources which needs reference counting. +%%% +%%% Should not be documented nor used directly by user applications. +%%%----------------------------------------------------------------- +start_link() -> + gen_server:start_link({local,kernel_refc}, kernel_refc, [], []). + +-spec scheduler_wall_time(boolean()) -> boolean(). +scheduler_wall_time(Bool) -> + gen_server:call(kernel_refc, {scheduler_wall_time, self(), Bool}, infinity). + +%%----------------------------------------------------------------- +%% Callback functions from gen_server +%%----------------------------------------------------------------- + +-spec init([]) -> {'ok', map()} | {'stop', term()}. + +init([]) -> + resource(scheduler_wall_time, false), + {ok, #{scheduler_wall_time=>#{}}}. + +-spec handle_call(term(), term(), State) -> {'reply', term(), State}. +handle_call({What, Who, false}, _From, State) -> + {Reply, Cnt} = do_stop(What, maps:get(What, State), Who), + {reply, Reply, State#{What:=Cnt}}; +handle_call({What, Who, true}, _From, State) -> + {Reply, Cnt} = do_start(What, maps:get(What, State), Who), + {reply, Reply, State#{What:=Cnt}}; +handle_call(_, _From, State) -> + {reply, badarg, State}. + +-spec handle_cast(term(), State) -> {'noreply', State}. +handle_cast(_, State) -> + {noreply, State}. + +-spec handle_info(term(), State) -> {'noreply', State}. +handle_info({'DOWN', _Ref, process, Pid, _}, State) -> + Cleanup = fun(Resource, Cnts) -> + cleanup(Resource, Cnts, Pid) + end, + {noreply, maps:map(Cleanup, State)}; +handle_info(_, State) -> + {noreply, State}. + +-spec terminate(term(), term()) -> 'ok'. +terminate(_Reason, _State) -> + ok. + +-spec code_change(term(), State, term()) -> {'ok', State}. +code_change(_OldVsn, State, _Extra) -> + {ok, State}. + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- + +do_start(Resource, Cnt, Pid) -> + case maps:get(Pid, Cnt, undefined) of + undefined -> + Ref = erlang:monitor(process, Pid), + case any(Cnt) of + true -> + {true, Cnt#{Pid=>{1, Ref}}}; + false -> + resource(Resource, true), + {false, Cnt#{Pid=>{1, Ref}}} + end; + {N, Ref} -> + {true, Cnt#{Pid=>{N+1, Ref}}} + end. + +do_stop(Resource, Cnt0, Pid) -> + case maps:get(Pid, Cnt0, undefined) of + undefined -> + {any(Cnt0), Cnt0}; + {1, Ref} -> + erlang:demonitor(Ref, [flush]), + Cnt = maps:remove(Pid, Cnt0), + case any(Cnt) of + true -> + {true, Cnt}; + false -> + resource(Resource, false), + {true, Cnt} + end; + {N, Ref} -> + {true, Cnt0#{Pid=>{N-1, Ref}}} + end. + +cleanup(Resource, Cnt0, Pid) -> + case maps:is_key(Pid, Cnt0) of + true -> + Cnt = maps:remove(Pid, Cnt0), + case any(Cnt) of + true -> + Cnt; + false -> + resource(Resource, false), + Cnt + end; + false -> + Cnt0 + end. + +any(Cnt) -> maps:size(Cnt) > 0. + +resource(scheduler_wall_time, Enable) -> + _ = erts_internal:scheduler_wall_time(Enable). diff --git a/lib/kernel/src/net_kernel.erl b/lib/kernel/src/net_kernel.erl index f36b4f1e6a..cdb10a7b12 100644 --- a/lib/kernel/src/net_kernel.erl +++ b/lib/kernel/src/net_kernel.erl @@ -70,8 +70,8 @@ protocol_childspecs/0, epmd_module/0]). --export([connect/1, disconnect/1, hidden_connect/1, passive_cnct/1]). --export([hidden_connect_node/1]). %% explicit connect +-export([disconnect/1, passive_cnct/1]). +-export([hidden_connect_node/1]). -export([set_net_ticktime/1, set_net_ticktime/2, get_net_ticktime/0]). -export([node_info/1, node_info/2, nodes_info/0, @@ -122,6 +122,7 @@ -record(connection, { node, %% remote node name + conn_id, %% Connection identity state, %% pending | up | up_pending owner, %% owner pid pending_owner, %% possible new owner @@ -247,14 +248,15 @@ ticktime_res(A) when is_atom(A) -> A. %% Called though BIF's -connect(Node) -> do_connect(Node, normal, false). %%% Long timeout if blocked (== barred), only affects nodes with %%% {dist_auto_connect, once} set. -passive_cnct(Node) -> do_connect(Node, normal, true). -disconnect(Node) -> request({disconnect, Node}). +passive_cnct(Node) -> + case request({passive_cnct, Node}) of + ignored -> false; + Other -> Other + end. -%% connect but not seen -hidden_connect(Node) -> do_connect(Node, hidden, false). +disconnect(Node) -> request({disconnect, Node}). %% Should this node publish itself on Node? publish_on_node(Node) when is_atom(Node) -> @@ -272,67 +274,30 @@ connect_node(Node) when is_atom(Node) -> hidden_connect_node(Node) when is_atom(Node) -> request({connect, hidden, Node}). -do_connect(Node, Type, WaitForBarred) -> %% Type = normal | hidden - case catch ets:lookup(sys_dist, Node) of - {'EXIT', _} -> - ?connect_failure(Node,{table_missing, sys_dist}), - false; - [#barred_connection{}] -> - case WaitForBarred of - false -> - false; - true -> - Pid = spawn(?MODULE,passive_connect_monitor,[self(),Node]), - receive - {Pid, true} -> - %%io:format("Net Kernel: barred connection (~p) " - %% "connected from other end.~n",[Node]), - true; - {Pid, false} -> - ?connect_failure(Node,{barred_connection, - ets:lookup(sys_dist, Node)}), - %%io:format("Net Kernel: barred connection (~p) " - %% "- failure.~n",[Node]), - false - end - end; - Else -> - case application:get_env(kernel, dist_auto_connect) of - {ok, never} -> - ?connect_failure(Node,{dist_auto_connect,never}), - false; - % This might happen due to connection close - % not beeing propagated to user space yet. - % Save the day by just not connecting... - {ok, once} when Else =/= [], - (hd(Else))#connection.state =:= up -> - ?connect_failure(Node,{barred_connection, - ets:lookup(sys_dist, Node)}), - false; - _ -> - request({connect, Type, Node}) - end - end. -passive_connect_monitor(Parent, Node) -> +passive_connect_monitor(From, Node) -> ok = monitor_nodes(true,[{node_type,all}]), - case lists:member(Node,nodes([connected])) of - true -> - ok = monitor_nodes(false,[{node_type,all}]), - Parent ! {self(),true}; - _ -> - Ref = make_ref(), - Tref = erlang:send_after(connecttime(),self(),Ref), - receive - Ref -> - ok = monitor_nodes(false,[{node_type,all}]), - Parent ! {self(), false}; - {nodeup,Node,_} -> - ok = monitor_nodes(false,[{node_type,all}]), - _ = erlang:cancel_timer(Tref), - Parent ! {self(),true} - end - end. + Reply = case lists:member(Node,nodes([connected])) of + true -> + io:format("~p: passive_connect_monitor ~p\n", [self(), ?LINE]), + true; + _ -> + receive + {nodeup,Node,_} -> + io:format("~p: passive_connect_monitor ~p\n", [self(), ?LINE]), + true + after connecttime() -> + io:format("~p: passive_connect_monitor ~p\n", [self(), ?LINE]), + false + end + end, + ok = monitor_nodes(false,[{node_type,all}]), + io:format("~p: passive_connect_monitor ~p\n", [self(), ?LINE]), + {Pid, Tag} = From, + io:format("~p: passive_connect_monitor ~p\n", [self(), ?LINE]), + erlang:send(Pid, {Tag, Reply}), + io:format("~p: passive_connect_monitor ~p\n", [self(), ?LINE]). + %% If the net_kernel isn't running we ignore all requests to the %% kernel, thus basically accepting them :-) @@ -394,40 +359,135 @@ init({Name, LongOrShortNames, TickT, CleanHalt}) -> end. +do_auto_connect(Type, Node, ConnId, WaitForBarred, From, State) -> + ConnLookup = ets:lookup(sys_dist, Node), + + case ConnLookup of + [#barred_connection{}] -> + case WaitForBarred of + false -> + {reply, false, State}; + true -> + spawn(?MODULE,passive_connect_monitor,[From,Node]), + {noreply, State} + end; + + [#connection{conn_id=ConnId, state = up}] -> + {reply, true, State}; + [#connection{conn_id=ConnId, waiting=Waiting}=Conn] -> + case From of + noreply -> ok; + _ -> ets:insert(sys_dist, Conn#connection{waiting = [From|Waiting]}) + end, + {noreply, State}; + + _ -> + case application:get_env(kernel, dist_auto_connect) of + {ok, never} -> + ?connect_failure(Node,{dist_auto_connect,never}), + {reply, false, State}; + + %% This might happen due to connection close + %% not beeing propagated to user space yet. + %% Save the day by just not connecting... + {ok, once} when ConnLookup =/= [], + (hd(ConnLookup))#connection.state =:= up -> + ?connect_failure(Node,{barred_connection, + ets:lookup(sys_dist, Node)}), + {reply, false, State}; + _ -> + case setup(ConnLookup, Node,ConnId,Type,From,State) of + {ok, SetupPid} -> + Owners = [{SetupPid, Node} | State#state.conn_owners], + {noreply,State#state{conn_owners=Owners}}; + _Error -> + ?connect_failure(Node, {setup_call, failed, _Error}), + {reply, false, State} + end + end + end. + + +do_explicit_connect([#connection{conn_id = ConnId, state = up}], _, _, ConnId, _From, State) -> + {reply, true, State}; +do_explicit_connect([#connection{conn_id = ConnId}=Conn], _, _, ConnId, From, State) + when Conn#connection.state =:= pending; + Conn#connection.state =:= up_pending -> + Waiting = Conn#connection.waiting, + ets:insert(sys_dist, Conn#connection{waiting = [From|Waiting]}), + {noreply, State}; +do_explicit_connect([#barred_connection{}], Type, Node, ConnId, From , State) -> + %% Barred connection only affects auto_connect, ignore it. + do_explicit_connect([], Type, Node, ConnId, From , State); +do_explicit_connect(ConnLookup, Type, Node, ConnId, From , State) -> + case setup(ConnLookup, Node,ConnId,Type,From,State) of + {ok, SetupPid} -> + Owners = [{SetupPid, Node} | State#state.conn_owners], + {noreply,State#state{conn_owners=Owners}}; + _Error -> + ?connect_failure(Node, {setup_call, failed, _Error}), + {reply, false, State} + end. + +-define(ERTS_DIST_CON_ID_MASK, 16#ffffff). % also in external.h + +verify_new_conn_id([], {Nr,_DHandle}) + when (Nr band (bnot ?ERTS_DIST_CON_ID_MASK)) =:= 0 -> + true; +verify_new_conn_id([#connection{conn_id = {Old,_}}], {New,_}) + when New =:= ((Old+1) band ?ERTS_DIST_CON_ID_MASK) -> + true; +verify_new_conn_id(_, _) -> + false. + + + %% ------------------------------------------------------------ %% handle_call. %% ------------------------------------------------------------ %% -%% Set up a connection to Node. -%% The response is delayed until the connection is up and -%% running. +%% Passive auto-connect to Node. +%% The response is delayed until the connection is up and running. %% -handle_call({connect, _, Node}, From, State) when Node =:= node() -> +handle_call({passive_cnct, Node}, From, State) when Node =:= node() -> + async_reply({reply, true, State}, From); +handle_call({passive_cnct, Node}, From, State) -> + verbose({passive_cnct, Node}, 1, State), + Type = normal, + WaitForBarred = true, + R = case (catch erts_internal:new_connection(Node)) of + {Nr,_DHandle}=ConnId when is_integer(Nr) -> + do_auto_connect(Type, Node, ConnId, WaitForBarred, From, State); + + _Error -> + error_logger:error_msg("~n** Cannot get connection id for node ~w~n", + [Node]), + {reply, false, State} + end, + + return_call(R, From); + +%% +%% Explicit connect +%% The response is delayed until the connection is up and running. +%% +handle_call({connect, _, Node, _, _}, From, State) when Node =:= node() -> async_reply({reply, true, State}, From); handle_call({connect, Type, Node}, From, State) -> verbose({connect, Type, Node}, 1, State), - case ets:lookup(sys_dist, Node) of - [Conn] when Conn#connection.state =:= up -> - async_reply({reply, true, State}, From); - [Conn] when Conn#connection.state =:= pending -> - Waiting = Conn#connection.waiting, - ets:insert(sys_dist, Conn#connection{waiting = [From|Waiting]}), - {noreply, State}; - [Conn] when Conn#connection.state =:= up_pending -> - Waiting = Conn#connection.waiting, - ets:insert(sys_dist, Conn#connection{waiting = [From|Waiting]}), - {noreply, State}; - _ -> - case setup(Node,Type,From,State) of - {ok, SetupPid} -> - Owners = [{SetupPid, Node} | State#state.conn_owners], - {noreply,State#state{conn_owners=Owners}}; - _Error -> - ?connect_failure(Node, {setup_call, failed, _Error}), - async_reply({reply, false, State}, From) - end - end; + ConnLookup = ets:lookup(sys_dist, Node), + R = case (catch erts_internal:new_connection(Node)) of + {Nr,_DHandle}=ConnId when is_integer(Nr) -> + do_explicit_connect(ConnLookup, Type, Node, ConnId, From, State); + + _Error -> + error_logger:error_msg("~n** Cannot get connection id for node ~w~n", + [Node]), + {reply, false, State} + end, + return_call(R, From); + %% %% Close the connection to Node. @@ -634,6 +694,26 @@ terminate(_Reason, State) -> %% ------------------------------------------------------------ %% +%% Asynchronous auto connect request +%% +handle_info({auto_connect,Node, Nr, DHandle}, State) -> + verbose({auto_connect, Node, Nr, DHandle}, 1, State), + ConnId = {Nr, DHandle}, + NewState = + case do_auto_connect(normal, Node, ConnId, false, noreply, State) of + {noreply, S} -> %% Pending connection + S; + + {reply, true, S} -> %% Already connected + S; + + {reply, false, S} -> %% Connection refused + erts_internal:abort_connection(Node, ConnId), + S + end, + {noreply, NewState}; + +%% %% accept a new connection. %% handle_info({accept,AcceptPid,Socket,Family,Proto}, State) -> @@ -713,14 +793,23 @@ handle_info({AcceptPid, {accept_pending,MyNode,Node,Address,Type}}, State) -> AcceptPid ! {self(), {accept_pending, already_pending}}, {noreply, State}; _ -> - ets:insert(sys_dist, #connection{node = Node, - state = pending, - owner = AcceptPid, - address = Address, - type = Type}), - AcceptPid ! {self(),{accept_pending,ok}}, - Owners = [{AcceptPid,Node} | State#state.conn_owners], - {noreply, State#state{conn_owners = Owners}} + case (catch erts_internal:new_connection(Node)) of + {Nr,_DHandle}=ConnId when is_integer(Nr) -> + ets:insert(sys_dist, #connection{node = Node, + conn_id = ConnId, + state = pending, + owner = AcceptPid, + address = Address, + type = Type}), + AcceptPid ! {self(),{accept_pending,ok}}, + Owners = [{AcceptPid,Node} | State#state.conn_owners], + {noreply, State#state{conn_owners = Owners}}; + + _ -> + error_logger:error_msg("~n** Cannot get connection id for node ~w~n", + [Node]), + AcceptPid ! {self(),{accept_pending,nok_pending}} + end end; handle_info({SetupPid, {is_pending, Node}}, State) -> @@ -906,6 +995,7 @@ pending_nodedown(Conn, Node, Type, State) -> % Don't bar connections that have never been alive %mark_sys_dist_nodedown(Node), % - instead just delete the node: + erts_internal:abort_connection(Node, Conn#connection.conn_id), ets:delete(sys_dist, Node), reply_waiting(Node,Conn#connection.waiting, false), case Type of @@ -920,7 +1010,9 @@ up_pending_nodedown(Conn, Node, _Reason, _Type, State) -> AcceptPid = Conn#connection.pending_owner, Owners = State#state.conn_owners, Pend = lists:keydelete(AcceptPid, 1, State#state.pend_owners), + erts_internal:abort_connection(Node, Conn#connection.conn_id), Conn1 = Conn#connection { owner = AcceptPid, + conn_id = erts_internal:new_connection(Node), pending_owner = undefined, state = pending }, ets:insert(sys_dist, Conn1), @@ -928,15 +1020,16 @@ up_pending_nodedown(Conn, Node, _Reason, _Type, State) -> State#state{conn_owners = [{AcceptPid,Node}|Owners], pend_owners = Pend}. -up_nodedown(_Conn, Node, _Reason, Type, State) -> - mark_sys_dist_nodedown(Node), +up_nodedown(Conn, Node, _Reason, Type, State) -> + mark_sys_dist_nodedown(Conn, Node), case Type of normal -> ?nodedown(Node, State); _ -> ok end, State. -mark_sys_dist_nodedown(Node) -> +mark_sys_dist_nodedown(Conn, Node) -> + erts_internal:abort_connection(Node, Conn#connection.conn_id), case application:get_env(kernel, dist_auto_connect) of {ok, once} -> ets:insert(sys_dist, #barred_connection{node = Node}); @@ -1179,15 +1272,8 @@ spawn_func(_,{From,Tag},M,F,A,Gleader) -> %% Set up connection to a new node. %% ----------------------------------------------------------- -setup(Node,Type,From,State) -> - Allowed = State#state.allowed, - case lists:member(Node, Allowed) of - false when Allowed =/= [] -> - error_msg("** Connection attempt with " - "disallowed node ~w ** ~n", [Node]), - {error, bad_node}; - _ -> - case select_mod(Node, State#state.listen) of +setup(ConnLookup, Node,ConnId,Type,From,State) -> + case setup_check(ConnLookup, Node, ConnId, State) of {ok, L} -> Mod = L#listen.module, LAddr = L#listen.address, @@ -1200,18 +1286,45 @@ setup(Node,Type,From,State) -> Addr = LAddr#net_address { address = undefined, host = undefined }, + Waiting = case From of + noreply -> []; + _ -> [From] + end, ets:insert(sys_dist, #connection{node = Node, + conn_id = ConnId, state = pending, owner = Pid, - waiting = [From], + waiting = Waiting, address = Addr, type = normal}), {ok, Pid}; Error -> Error - end end. +setup_check(ConnLookup, Node, ConnId, State) -> + Allowed = State#state.allowed, + case lists:member(Node, Allowed) of + false when Allowed =/= [] -> + error_msg("** Connection attempt with " + "disallowed node ~w ** ~n", [Node]), + {error, bad_node}; + _ -> + case verify_new_conn_id(ConnLookup, ConnId) of + false -> + error_msg("** Connection attempt to ~w with " + "bad connection id ~w ** ~n", [Node, ConnId]), + {error, bad_conn_id}; + true -> + case select_mod(Node, State#state.listen) of + {ok, _L}=OK -> OK; + Error -> Error + end + end + end. + + + %% %% Find a module that is willing to handle connection setup to Node %% @@ -1652,6 +1765,11 @@ verbose(_, _, _) -> getnode(P) when is_pid(P) -> node(P); getnode(P) -> P. +return_call({noreply, _State}=R, _From) -> + R; +return_call(R, From) -> + async_reply(R, From). + async_reply({reply, Msg, State}, From) -> async_gen_server_reply(From, Msg), {noreply, State}. diff --git a/lib/kernel/src/os.erl b/lib/kernel/src/os.erl index b5f19d4b99..fbc046c8f9 100644 --- a/lib/kernel/src/os.erl +++ b/lib/kernel/src/os.erl @@ -27,12 +27,13 @@ -export_type([env_var_name/0, env_var_value/0, env_var_name_value/0, command_input/0]). +-export([getenv/0, getenv/1, getenv/2, putenv/2, unsetenv/1]). + %%% BIFs --export([getenv/0, getenv/1, getenv/2, getpid/0, - perf_counter/0, perf_counter/1, - putenv/2, set_signal/2, system_time/0, system_time/1, - timestamp/0, unsetenv/1]). +-export([get_env_var/1, getpid/0, list_env_vars/0, perf_counter/0, + perf_counter/1, set_env_var/2, set_signal/2, system_time/0, + system_time/1, timestamp/0, unset_env_var/1]). -type env_var_name() :: nonempty_string(). @@ -42,29 +43,15 @@ -type command_input() :: atom() | io_lib:chars(). --spec getenv() -> [env_var_name_value()]. - -getenv() -> erlang:nif_error(undef). - --spec getenv(VarName) -> Value | false when - VarName :: env_var_name(), - Value :: env_var_value(). - -getenv(_) -> +-spec list_env_vars() -> [{env_var_name(), env_var_value()}]. +list_env_vars() -> erlang:nif_error(undef). --spec getenv(VarName, DefaultValue) -> Value when +-spec get_env_var(VarName) -> Value | false when VarName :: env_var_name(), - DefaultValue :: env_var_value(), Value :: env_var_value(). - -getenv(VarName, DefaultValue) -> - case os:getenv(VarName) of - false -> - DefaultValue; - Value -> - Value - end. +get_env_var(_VarName) -> + erlang:nif_error(undef). -spec getpid() -> Value when Value :: string(). @@ -84,11 +71,10 @@ perf_counter() -> perf_counter(Unit) -> erlang:convert_time_unit(os:perf_counter(), perf_counter, Unit). --spec putenv(VarName, Value) -> true when +-spec set_env_var(VarName, Value) -> true when VarName :: env_var_name(), Value :: env_var_value(). - -putenv(_, _) -> +set_env_var(_, _) -> erlang:nif_error(undef). -spec system_time() -> integer(). @@ -108,10 +94,9 @@ system_time(_Unit) -> timestamp() -> erlang:nif_error(undef). --spec unsetenv(VarName) -> true when +-spec unset_env_var(VarName) -> true when VarName :: env_var_name(). - -unsetenv(_) -> +unset_env_var(_) -> erlang:nif_error(undef). -spec set_signal(Signal, Option) -> 'ok' when @@ -125,6 +110,39 @@ set_signal(_Signal, _Option) -> %%% End of BIFs +-spec getenv() -> [env_var_name_value()]. +getenv() -> + [lists:flatten([Key, $=, Value]) || {Key, Value} <- os:list_env_vars() ]. + +-spec getenv(VarName) -> Value | false when + VarName :: env_var_name(), + Value :: env_var_value(). +getenv(VarName) -> + os:get_env_var(VarName). + +-spec getenv(VarName, DefaultValue) -> Value when + VarName :: env_var_name(), + DefaultValue :: env_var_value(), + Value :: env_var_value(). +getenv(VarName, DefaultValue) -> + case os:getenv(VarName) of + false -> + DefaultValue; + Value -> + Value + end. + +-spec putenv(VarName, Value) -> true when + VarName :: env_var_name(), + Value :: env_var_value(). +putenv(VarName, Value) -> + os:set_env_var(VarName, Value). + +-spec unsetenv(VarName) -> true when + VarName :: env_var_name(). +unsetenv(VarName) -> + os:unset_env_var(VarName). + -spec type() -> {Osfamily, Osname} when Osfamily :: unix | win32, Osname :: atom(). diff --git a/lib/kernel/src/raw_file_io.erl b/lib/kernel/src/raw_file_io.erl new file mode 100644 index 0000000000..e3c07c8f78 --- /dev/null +++ b/lib/kernel/src/raw_file_io.erl @@ -0,0 +1,75 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. 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(raw_file_io). + +-export([open/2]). + +open(Filename, Modes) -> + %% Layers are applied in this order, and the listed modules will call this + %% function again as necessary. eg. a raw compressed delayed file in list + %% mode will walk through [_list -> _compressed -> _delayed -> _raw]. + ModuleOrder = [{raw_file_io_list, fun match_list/1}, + {raw_file_io_compressed, fun match_compressed/1}, + {raw_file_io_delayed, fun match_delayed/1}, + {raw_file_io_raw, fun match_raw/1}], + open_1(ModuleOrder, Filename, add_implicit_modes(Modes)). +open_1([], _Filename, _Modes) -> + error(badarg); +open_1([{Module, Match} | Rest], Filename, Modes) -> + case lists:any(Match, Modes) of + true -> + {Options, ChildModes} = + lists:partition(fun(Mode) -> Match(Mode) end, Modes), + Module:open_layer(Filename, ChildModes, Options); + false -> + open_1(Rest, Filename, Modes) + end. + +%% 'read' and 'list' mode are enabled unless disabled by another option, so +%% we'll explicitly add them to avoid duplicating this logic in child layers. +add_implicit_modes(Modes0) -> + Modes1 = add_unless_matched(Modes0, fun match_writable/1, read), + add_unless_matched(Modes1, fun match_binary/1, list). +add_unless_matched(Modes, Match, Default) -> + case lists:any(Match, Modes) of + false -> [Default | Modes]; + true -> Modes + end. + +match_list(list) -> true; +match_list(_Other) -> false. + +match_compressed(compressed) -> true; +match_compressed(_Other) -> false. + +match_delayed({delayed_write, _Size, _Timeout}) -> true; +match_delayed(delayed_write) -> true; +match_delayed(_Other) -> false. + +match_raw(raw) -> true; +match_raw(_Other) -> false. + +match_writable(write) -> true; +match_writable(append) -> true; +match_writable(exclusive) -> true; +match_writable(_Other) -> false. + +match_binary(binary) -> true; +match_binary(_Other) -> false. diff --git a/lib/kernel/src/raw_file_io_compressed.erl b/lib/kernel/src/raw_file_io_compressed.erl new file mode 100644 index 0000000000..d5ab042d25 --- /dev/null +++ b/lib/kernel/src/raw_file_io_compressed.erl @@ -0,0 +1,134 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. 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(raw_file_io_compressed). + +-export([close/1, sync/1, datasync/1, truncate/1, advise/4, allocate/3, + position/2, write/2, pwrite/2, pwrite/3, + read_line/1, read/2, pread/2, pread/3]). + +%% OTP internal. +-export([ipread_s32bu_p32bu/3, sendfile/8]). + +-export([open_layer/3]). + +-include("file_int.hrl"). + +open_layer(Filename, Modes, Options) -> + IsAppend = lists:member(append, Modes), + IsDeflate = lists:member(write, Modes), + IsInflate = lists:member(read, Modes), + if + IsDeflate, IsInflate; IsAppend -> + {error, einval}; + IsDeflate, not IsInflate -> + start_server_module(raw_file_io_deflate, Filename, Modes, Options); + IsInflate -> + start_server_module(raw_file_io_inflate, Filename, Modes, Options) + end. + +start_server_module(Module, Filename, Modes, Options) -> + Secret = make_ref(), + case gen_statem:start(Module, {self(), Secret, Options}, []) of + {ok, Pid} -> open_next_layer(Pid, Secret, Filename, Modes); + Other -> Other + end. + +open_next_layer(Pid, Secret, Filename, Modes) -> + case gen_statem:call(Pid, {'$open', Secret, Filename, Modes}, infinity) of + ok -> + PublicFd = #file_descriptor{ + module = raw_file_io_compressed, data = {self(), Pid} }, + {ok, PublicFd}; + Other -> Other + end. + +close(Fd) -> + wrap_call(Fd, [close]). + +sync(Fd) -> + wrap_call(Fd, [sync]). +datasync(Fd) -> + wrap_call(Fd, [datasync]). + +truncate(Fd) -> + wrap_call(Fd, [truncate]). + +advise(Fd, Offset, Length, Advise) -> + wrap_call(Fd, [advise, Offset, Length, Advise]). +allocate(Fd, Offset, Length) -> + wrap_call(Fd, [allocate, Offset, Length]). + +position(Fd, Mark) -> + wrap_call(Fd, [position, Mark]). + +write(Fd, IOData) -> + try + CompactedData = erlang:iolist_to_iovec(IOData), + wrap_call(Fd, [write, CompactedData]) + catch + error:badarg -> {error, badarg} + end. + +pwrite(Fd, Offset, IOData) -> + try + CompactedData = erlang:iolist_to_iovec(IOData), + wrap_call(Fd, [pwrite, Offset, CompactedData]) + catch + error:badarg -> {error, badarg} + end. +pwrite(Fd, LocBytes) -> + try + CompactedLocBytes = + [ {Offset, erlang:iolist_to_iovec(IOData)} || + {Offset, IOData} <- LocBytes ], + wrap_call(Fd, [pwrite, CompactedLocBytes]) + catch + error:badarg -> {error, badarg} + end. + +read_line(Fd) -> + wrap_call(Fd, [read_line]). +read(Fd, Size) -> + wrap_call(Fd, [read, Size]). +pread(Fd, Offset, Size) -> + wrap_call(Fd, [pread, Offset, Size]). +pread(Fd, LocNums) -> + wrap_call(Fd, [pread, LocNums]). + +ipread_s32bu_p32bu(Fd, Offset, MaxSize) -> + wrap_call(Fd, [ipread_s32bu_p32bu, Offset, MaxSize]). + +sendfile(_,_,_,_,_,_,_,_) -> + {error, enotsup}. + +wrap_call(Fd, Command) -> + {_Owner, Pid} = get_fd_data(Fd), + try gen_statem:call(Pid, Command, infinity) of + Result -> Result + catch + exit:{noproc, _StackTrace} -> {error, einval} + end. + +get_fd_data(#file_descriptor{ data = Data }) -> + {Owner, _ServerPid} = Data, + case self() of + Owner -> Data; + _ -> error(not_on_controlling_process) + end. diff --git a/lib/kernel/src/raw_file_io_deflate.erl b/lib/kernel/src/raw_file_io_deflate.erl new file mode 100644 index 0000000000..acfc546743 --- /dev/null +++ b/lib/kernel/src/raw_file_io_deflate.erl @@ -0,0 +1,159 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. 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(raw_file_io_deflate). + +-behavior(gen_statem). + +-export([init/1, callback_mode/0, terminate/3]). +-export([opening/3, opened/3]). + +-include("file_int.hrl"). + +-define(GZIP_WBITS, 16 + 15). + +callback_mode() -> state_functions. + +init({Owner, Secret, [compressed]}) -> + Monitor = monitor(process, Owner), + Z = zlib:open(), + ok = zlib:deflateInit(Z, default, deflated, ?GZIP_WBITS, 8, default), + Data = + #{ owner => Owner, + monitor => Monitor, + secret => Secret, + position => 0, + zlib => Z }, + {ok, opening, Data}. + +opening({call, From}, {'$open', Secret, Filename, Modes}, #{ secret := Secret } = Data) -> + case raw_file_io:open(Filename, Modes) of + {ok, PrivateFd} -> + NewData = Data#{ handle => PrivateFd }, + {next_state, opened, NewData, [{reply, From, ok}]}; + Other -> + {stop_and_reply, normal, [{reply, From, Other}]} + end; +opening(_Event, _Contents, _Data) -> + {keep_state_and_data, [postpone]}. + +%% + +opened(info, {'DOWN', Monitor, process, _Owner, Reason}, #{ monitor := Monitor } = Data) -> + if + Reason =/= kill -> flush_deflate_state(Data); + Reason =:= kill -> ignored + end, + {stop, shutdown}; + +opened(info, _Message, _Data) -> + keep_state_and_data; + +opened({call, {Owner, _Tag} = From}, [close], #{ owner := Owner } = Data) -> + #{ handle := PrivateFd } = Data, + Response = + case flush_deflate_state(Data) of + ok -> ?CALL_FD(PrivateFd, close, []); + Other -> Other + end, + {stop_and_reply, normal, [{reply, From, Response}]}; + +opened({call, {Owner, _Tag} = From}, [position, Mark], #{ owner := Owner } = Data) -> + case position(Data, Mark) of + {ok, NewData, Result} -> + Response = {ok, Result}, + {keep_state, NewData, [{reply, From, Response}]}; + Other -> + {keep_state_and_data, [{reply, From, Other}]} + end; + +opened({call, {Owner, _Tag} = From}, [write, IOVec], #{ owner := Owner } = Data) -> + case write(Data, IOVec) of + {ok, NewData} -> {keep_state, NewData, [{reply, From, ok}]}; + Other -> {keep_state_and_data, [{reply, From, Other}]} + end; + +opened({call, {Owner, _Tag} = From}, [read, _Size], #{ owner := Owner }) -> + Response = {error, ebadf}, + {keep_state_and_data, [{reply, From, Response}]}; + +opened({call, {Owner, _Tag} = From}, [read_line], #{ owner := Owner }) -> + Response = {error, ebadf}, + {keep_state_and_data, [{reply, From, Response}]}; + +opened({call, {Owner, _Tag} = From}, _Command, #{ owner := Owner }) -> + Response = {error, enotsup}, + {keep_state_and_data, [{reply, From, Response}]}; + +opened({call, _From}, _Command, _Data) -> + %% The client functions filter this out, so we'll crash if the user does + %% anything stupid on purpose. + {shutdown, protocol_violation}; + +opened(_Event, _Request, _Data) -> + keep_state_and_data. + +write(Data, IOVec) -> + #{ handle := PrivateFd, position := Position, zlib := Z } = Data, + UncompressedSize = iolist_size(IOVec), + case ?CALL_FD(PrivateFd, write, [zlib:deflate(Z, IOVec)]) of + ok -> {ok, Data#{ position := (Position + UncompressedSize) }}; + Other -> Other + end. + +%% +%% We support "seeking" forward as long as it isn't relative to EOF. +%% +%% Seeking is a bit of a misnomer as it's really just compressing zeroes until +%% we reach the desired point, but it has always behaved like this. +%% + +position(Data, Mark) when is_atom(Mark) -> + position(Data, {Mark, 0}); +position(Data, Offset) when is_integer(Offset) -> + position(Data, {bof, Offset}); +position(Data, {bof, Offset}) when is_integer(Offset) -> + position_1(Data, Offset); +position(Data, {cur, Offset}) when is_integer(Offset) -> + #{ position := Position } = Data, + position_1(Data, Position + Offset); +position(_Data, {eof, Offset}) when is_integer(Offset) -> + {error, einval}; +position(_Data, _Any) -> + {error, badarg}. + +position_1(#{ position := Desired } = Data, Desired) -> + {ok, Data, Desired}; +position_1(#{ position := Current } = Data, Desired) when Current < Desired -> + BytesToWrite = min(Desired - Current, 4 bsl 20), + case write(Data, <<0:(BytesToWrite)/unit:8>>) of + {ok, NewData} -> position_1(NewData, Desired); + Other -> Other + end; +position_1(#{ position := Current }, Desired) when Current > Desired -> + {error, einval}. + +flush_deflate_state(#{ handle := PrivateFd, zlib := Z }) -> + case ?CALL_FD(PrivateFd, write, [zlib:deflate(Z, [], finish)]) of + ok -> ok; + Other -> Other + end. + +terminate(_Reason, _State, _Data) -> + ok. diff --git a/lib/kernel/src/raw_file_io_delayed.erl b/lib/kernel/src/raw_file_io_delayed.erl new file mode 100644 index 0000000000..d2ad7550a1 --- /dev/null +++ b/lib/kernel/src/raw_file_io_delayed.erl @@ -0,0 +1,320 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. 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(raw_file_io_delayed). + +-behavior(gen_statem). + +-export([close/1, sync/1, datasync/1, truncate/1, advise/4, allocate/3, + position/2, write/2, pwrite/2, pwrite/3, + read_line/1, read/2, pread/2, pread/3]). + +%% OTP internal. +-export([ipread_s32bu_p32bu/3, sendfile/8]). + +-export([open_layer/3]). + +-export([init/1, callback_mode/0, terminate/3]). +-export([opening/3, opened/3]). + +-include("file_int.hrl"). + +open_layer(Filename, Modes, Options) -> + Secret = make_ref(), + case gen_statem:start(?MODULE, {self(), Secret, Options}, []) of + {ok, Pid} -> + gen_statem:call(Pid, {'$open', Secret, Filename, Modes}, infinity); + Other -> + Other + end. + +callback_mode() -> state_functions. + +init({Owner, Secret, Options}) -> + Monitor = monitor(process, Owner), + Defaults = + #{ owner => Owner, + monitor => Monitor, + secret => Secret, + timer => none, + pid => self(), + buffer => prim_buffer:new(), + delay_size => 64 bsl 10, + delay_time => 2000 }, + Data = fill_delay_values(Defaults, Options), + {ok, opening, Data}. + +fill_delay_values(Data, []) -> + Data; +fill_delay_values(Data, [{delayed_write, Size, Time} | Options]) -> + fill_delay_values(Data#{ delay_size => Size, delay_time => Time }, Options); +fill_delay_values(Data, [_ | Options]) -> + fill_delay_values(Data, Options). + +opening({call, From}, {'$open', Secret, Filename, Modes}, #{ secret := Secret } = Data) -> + case raw_file_io:open(Filename, Modes) of + {ok, PrivateFd} -> + PublicData = maps:with([owner, buffer, delay_size, pid], Data), + PublicFd = #file_descriptor{ module = ?MODULE, data = PublicData }, + + NewData = Data#{ handle => PrivateFd }, + Response = {ok, PublicFd}, + {next_state, opened, NewData, [{reply, From, Response}]}; + Other -> + {stop_and_reply, normal, [{reply, From, Other}]} + end; +opening(_Event, _Contents, _Data) -> + {keep_state_and_data, [postpone]}. + +%% + +opened(info, {'$timed_out', Secret}, #{ secret := Secret } = Data) -> + %% If the user writes something at this exact moment, the flush will fail + %% and the timer won't reset on the next write since the buffer won't be + %% empty (Unless we collided on a flush). We therefore reset the timeout to + %% ensure that data won't sit idle for extended periods of time. + case try_flush_write_buffer(Data) of + busy -> gen_statem:cast(self(), '$reset_timeout'); + ok -> ok + end, + {keep_state, Data#{ timer => none }, []}; + +opened(info, {'DOWN', Monitor, process, _Owner, Reason}, #{ monitor := Monitor } = Data) -> + if + Reason =/= kill -> try_flush_write_buffer(Data); + Reason =:= kill -> ignored + end, + {stop, shutdown}; + +opened(info, _Message, _Data) -> + keep_state_and_data; + +opened({call, {Owner, _Tag} = From}, [close], #{ owner := Owner } = Data) -> + case flush_write_buffer(Data) of + ok -> + #{ handle := PrivateFd } = Data, + Response = ?CALL_FD(PrivateFd, close, []), + {stop_and_reply, normal, [{reply, From, Response}]}; + Other -> + {stop_and_reply, normal, [{reply, From, Other}]} + end; + +opened({call, {Owner, _Tag} = From}, '$wait', #{ owner := Owner }) -> + %% Used in write/2 to synchronize writes on lock conflicts. + {keep_state_and_data, [{reply, From, ok}]}; + +opened({call, {Owner, _Tag} = From}, '$synchronous_flush', #{ owner := Owner } = Data) -> + cancel_flush_timeout(Data), + Response = flush_write_buffer(Data), + {keep_state_and_data, [{reply, From, Response}]}; + +opened({call, {Owner, _Tag} = From}, Command, #{ owner := Owner } = Data) -> + Response = + case flush_write_buffer(Data) of + ok -> dispatch_command(Data, Command); + Other -> Other + end, + {keep_state_and_data, [{reply, From, Response}]}; + +opened({call, _From}, _Command, _Data) -> + %% The client functions filter this out, so we'll crash if the user does + %% anything stupid on purpose. + {shutdown, protocol_violation}; + +opened(cast, '$reset_timeout', #{ delay_time := Timeout, secret := Secret } = Data) -> + cancel_flush_timeout(Data), + Timer = erlang:send_after(Timeout, self(), {'$timed_out', Secret}), + {keep_state, Data#{ timer => Timer }, []}; + +opened(cast, _Message, _Data) -> + {keep_state_and_data, []}. + +dispatch_command(Data, [Function | Args]) -> + #{ handle := Handle } = Data, + Module = Handle#file_descriptor.module, + apply(Module, Function, [Handle | Args]). + +cancel_flush_timeout(#{ timer := none }) -> + ok; +cancel_flush_timeout(#{ timer := Timer }) -> + _ = erlang:cancel_timer(Timer, [{async, true}]), + ok. + +try_flush_write_buffer(#{ buffer := Buffer, handle := PrivateFd }) -> + case prim_buffer:try_lock(Buffer) of + acquired -> + flush_write_buffer_1(Buffer, PrivateFd), + prim_buffer:unlock(Buffer), + ok; + busy -> + busy + end. + +%% This is only safe to use when there is no chance of conflict with the owner +%% process, or in other words, "during synchronous calls outside of the locked +%% section of write/2" +flush_write_buffer(#{ buffer := Buffer, handle := PrivateFd }) -> + acquired = prim_buffer:try_lock(Buffer), + Result = flush_write_buffer_1(Buffer, PrivateFd), + prim_buffer:unlock(Buffer), + Result. + +flush_write_buffer_1(Buffer, PrivateFd) -> + case prim_buffer:size(Buffer) of + Size when Size > 0 -> + ?CALL_FD(PrivateFd, write, [prim_buffer:read_iovec(Buffer, Size)]); + 0 -> + ok + end. + +terminate(_Reason, _State, _Data) -> + ok. + +%% Client functions + +write(Fd, IOData) -> + try + enqueue_write(Fd, erlang:iolist_to_iovec(IOData)) + catch + error:badarg -> {error, badarg} + end. +enqueue_write(_Fd, []) -> + ok; +enqueue_write(Fd, IOVec) -> + %% get_fd_data will reject everyone except the process that opened the Fd, + %% so we can't race with anyone except the wrapper process. + #{ delay_size := DelaySize, + buffer := Buffer, + pid := Pid } = get_fd_data(Fd), + case prim_buffer:try_lock(Buffer) of + acquired -> + %% (The wrapper process will exit without flushing if we're killed + %% while holding the lock). + enqueue_write_locked(Pid, Buffer, DelaySize, IOVec); + busy -> + %% This can only happen while we're processing a timeout in the + %% wrapper process, so we perform a bogus call to get a completion + %% notification before trying again. + gen_statem:call(Pid, '$wait'), + enqueue_write(Fd, IOVec) + end. +enqueue_write_locked(Pid, Buffer, DelaySize, IOVec) -> + %% The synchronous operations (write, forced flush) are safe since we're + %% running on the only process that can fill the buffer; a timeout being + %% processed just before $synchronous_flush will cause the flush to nop, + %% and a timeout sneaking in just before a synchronous write won't do + %% anything since the buffer is guaranteed to be empty at that point. + BufSize = prim_buffer:size(Buffer), + case is_iovec_smaller_than(IOVec, DelaySize - BufSize) of + true when BufSize > 0 -> + prim_buffer:write(Buffer, IOVec), + prim_buffer:unlock(Buffer); + true -> + prim_buffer:write(Buffer, IOVec), + prim_buffer:unlock(Buffer), + gen_statem:cast(Pid, '$reset_timeout'); + false when BufSize > 0 -> + prim_buffer:write(Buffer, IOVec), + prim_buffer:unlock(Buffer), + gen_statem:call(Pid, '$synchronous_flush'); + false -> + prim_buffer:unlock(Buffer), + gen_statem:call(Pid, [write, IOVec]) + end. + +%% iolist_size/1 will always look through the entire list to get a precise +%% amount, which is pretty inefficient since we only need to know whether we've +%% hit the buffer threshold or not. +%% +%% We only handle the binary case since write/2 forcibly translates input to +%% erlang:iovec(). +is_iovec_smaller_than(IOVec, Max) -> + is_iovec_smaller_than_1(IOVec, Max, 0). +is_iovec_smaller_than_1(_IOVec, Max, Acc) when Acc >= Max -> + false; +is_iovec_smaller_than_1([], _Max, _Acc) -> + true; +is_iovec_smaller_than_1([Binary | Rest], Max, Acc) when is_binary(Binary) -> + is_iovec_smaller_than_1(Rest, Max, Acc + byte_size(Binary)). + +close(Fd) -> + wrap_call(Fd, [close]). + +sync(Fd) -> + wrap_call(Fd, [sync]). +datasync(Fd) -> + wrap_call(Fd, [datasync]). + +truncate(Fd) -> + wrap_call(Fd, [truncate]). + +advise(Fd, Offset, Length, Advise) -> + wrap_call(Fd, [advise, Offset, Length, Advise]). +allocate(Fd, Offset, Length) -> + wrap_call(Fd, [allocate, Offset, Length]). + +position(Fd, Mark) -> + wrap_call(Fd, [position, Mark]). + +pwrite(Fd, Offset, IOData) -> + try + CompactedData = erlang:iolist_to_iovec(IOData), + wrap_call(Fd, [pwrite, Offset, CompactedData]) + catch + error:badarg -> {error, badarg} + end. +pwrite(Fd, LocBytes) -> + try + CompactedLocBytes = + [ {Offset, erlang:iolist_to_iovec(IOData)} || + {Offset, IOData} <- LocBytes ], + wrap_call(Fd, [pwrite, CompactedLocBytes]) + catch + error:badarg -> {error, badarg} + end. + +read_line(Fd) -> + wrap_call(Fd, [read_line]). +read(Fd, Size) -> + wrap_call(Fd, [read, Size]). +pread(Fd, Offset, Size) -> + wrap_call(Fd, [pread, Offset, Size]). +pread(Fd, LocNums) -> + wrap_call(Fd, [pread, LocNums]). + +ipread_s32bu_p32bu(Fd, Offset, MaxSize) -> + wrap_call(Fd, [ipread_s32bu_p32bu, Offset, MaxSize]). + +sendfile(_,_,_,_,_,_,_,_) -> + {error, enotsup}. + +wrap_call(Fd, Command) -> + #{ pid := Pid } = get_fd_data(Fd), + try gen_statem:call(Pid, Command, infinity) of + Result -> Result + catch + exit:{noproc, _StackTrace} -> {error, einval} + end. + +get_fd_data(#file_descriptor{ data = Data }) -> + #{ owner := Owner } = Data, + case self() of + Owner -> Data; + _ -> error(not_on_controlling_process) + end. diff --git a/lib/kernel/src/raw_file_io_inflate.erl b/lib/kernel/src/raw_file_io_inflate.erl new file mode 100644 index 0000000000..7e9780310c --- /dev/null +++ b/lib/kernel/src/raw_file_io_inflate.erl @@ -0,0 +1,261 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. 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(raw_file_io_inflate). + +-behavior(gen_statem). + +-export([init/1, callback_mode/0, terminate/3]). +-export([opening/3, opened_gzip/3, opened_passthrough/3]). + +-include("file_int.hrl"). + +-define(INFLATE_CHUNK_SIZE, (1 bsl 10)). +-define(GZIP_WBITS, (16 + 15)). + +callback_mode() -> state_functions. + +init({Owner, Secret, [compressed]}) -> + Monitor = monitor(process, Owner), + %% We're using the undocumented inflateInit/3 to open the stream in + %% 'reset mode', which resets the inflate state at the end of every stream, + %% allowing us to read concatenated gzip files. + Z = zlib:open(), + ok = zlib:inflateInit(Z, ?GZIP_WBITS, reset), + Data = + #{ owner => Owner, + monitor => Monitor, + secret => Secret, + position => 0, + buffer => prim_buffer:new(), + zlib => Z }, + {ok, opening, Data}. + +%% The old driver fell back to plain reads if the file didn't start with the +%% magic gzip bytes. +choose_decompression_state(PrivateFd) -> + State = + case ?CALL_FD(PrivateFd, read, [2]) of + {ok, <<16#1F, 16#8B>>} -> opened_gzip; + _Other -> opened_passthrough + end, + {ok, 0} = ?CALL_FD(PrivateFd, position, [0]), + State. + +opening({call, From}, {'$open', Secret, Filename, Modes}, #{ secret := Secret } = Data) -> + case raw_file_io:open(Filename, Modes) of + {ok, PrivateFd} -> + NextState = choose_decompression_state(PrivateFd), + NewData = Data#{ handle => PrivateFd }, + {next_state, NextState, NewData, [{reply, From, ok}]}; + Other -> + {stop_and_reply, normal, [{reply, From, Other}]} + end; +opening(_Event, _Contents, _Data) -> + {keep_state_and_data, [postpone]}. + +internal_close(From, Data) -> + #{ handle := PrivateFd } = Data, + Response = ?CALL_FD(PrivateFd, close, []), + {stop_and_reply, normal, [{reply, From, Response}]}. + +opened_passthrough(info, {'DOWN', Monitor, process, _Owner, _Reason}, #{ monitor := Monitor }) -> + {stop, shutdown}; + +opened_passthrough(info, _Message, _Data) -> + keep_state_and_data; + +opened_passthrough({call, {Owner, _Tag} = From}, [close], #{ owner := Owner } = Data) -> + internal_close(From, Data); + +opened_passthrough({call, {Owner, _Tag} = From}, [Method | Args], #{ owner := Owner } = Data) -> + #{ handle := PrivateFd } = Data, + Response = ?CALL_FD(PrivateFd, Method, Args), + {keep_state_and_data, [{reply, From, Response}]}; + +opened_passthrough({call, _From}, _Command, _Data) -> + %% The client functions filter this out, so we'll crash if the user does + %% anything stupid on purpose. + {shutdown, protocol_violation}; + +opened_passthrough(_Event, _Request, _Data) -> + keep_state_and_data. + +%% + +opened_gzip(info, {'DOWN', Monitor, process, _Owner, _Reason}, #{ monitor := Monitor }) -> + {stop, shutdown}; + +opened_gzip(info, _Message, _Data) -> + keep_state_and_data; + +opened_gzip({call, {Owner, _Tag} = From}, [close], #{ owner := Owner } = Data) -> + internal_close(From, Data); + +opened_gzip({call, {Owner, _Tag} = From}, [position, Mark], #{ owner := Owner } = Data) -> + case position(Data, Mark) of + {ok, NewData, Result} -> + Response = {ok, Result}, + {keep_state, NewData, [{reply, From, Response}]}; + Other -> + {keep_state_and_data, [{reply, From, Other}]} + end; + +opened_gzip({call, {Owner, _Tag} = From}, [read, Size], #{ owner := Owner } = Data) -> + case read(Data, Size) of + {ok, NewData, Result} -> + Response = {ok, Result}, + {keep_state, NewData, [{reply, From, Response}]}; + Other -> + {keep_state_and_data, [{reply, From, Other}]} + end; + +opened_gzip({call, {Owner, _Tag} = From}, [read_line], #{ owner := Owner } = Data) -> + case read_line(Data) of + {ok, NewData, Result} -> + Response = {ok, Result}, + {keep_state, NewData, [{reply, From, Response}]}; + Other -> + {keep_state_and_data, [{reply, From, Other}]} + end; + +opened_gzip({call, {Owner, _Tag} = From}, [write, _IOData], #{ owner := Owner }) -> + Response = {error, ebadf}, + {keep_state_and_data, [{reply, From, Response}]}; + +opened_gzip({call, {Owner, _Tag} = From}, _Request, #{ owner := Owner }) -> + Response = {error, enotsup}, + {keep_state_and_data, [{reply, From, Response}]}; + +opened_gzip({call, _From}, _Request, _Data) -> + %% The client functions filter this out, so we'll crash if the user does + %% anything stupid on purpose. + {shutdown, protocol_violation}; + +opened_gzip(_Event, _Request, _Data) -> + keep_state_and_data. + +%% + +read(#{ buffer := Buffer } = Data, Size) -> + try read_1(Data, Buffer, prim_buffer:size(Buffer), Size) of + Result -> Result + catch + error:badarg -> {error, badarg}; + error:_ -> {error, eio} + end. +read_1(Data, Buffer, BufferSize, ReadSize) when BufferSize >= ReadSize -> + #{ position := Position } = Data, + Decompressed = prim_buffer:read(Buffer, ReadSize), + {ok, Data#{ position => (Position + ReadSize) }, Decompressed}; +read_1(Data, Buffer, BufferSize, ReadSize) when BufferSize < ReadSize -> + #{ handle := PrivateFd } = Data, + case ?CALL_FD(PrivateFd, read, [?INFLATE_CHUNK_SIZE]) of + {ok, Compressed} -> + #{ zlib := Z } = Data, + Uncompressed = erlang:iolist_to_iovec(zlib:inflate(Z, Compressed)), + prim_buffer:write(Buffer, Uncompressed), + read_1(Data, Buffer, prim_buffer:size(Buffer), ReadSize); + eof when BufferSize > 0 -> + read_1(Data, Buffer, BufferSize, BufferSize); + Other -> + Other + end. + +read_line(#{ buffer := Buffer } = Data) -> + try read_line_1(Data, Buffer, prim_buffer:find_byte_index(Buffer, $\n)) of + {ok, NewData, Decompressed} -> {ok, NewData, Decompressed}; + Other -> Other + catch + error:badarg -> {error, badarg}; + error:_ -> {error, eio} + end. + +read_line_1(Data, Buffer, not_found) -> + #{ handle := PrivateFd, zlib := Z } = Data, + case ?CALL_FD(PrivateFd, read, [?INFLATE_CHUNK_SIZE]) of + {ok, Compressed} -> + Uncompressed = erlang:iolist_to_iovec(zlib:inflate(Z, Compressed)), + prim_buffer:write(Buffer, Uncompressed), + read_line_1(Data, Buffer, prim_buffer:find_byte_index(Buffer, $\n)); + eof -> + case prim_buffer:size(Buffer) of + Size when Size > 0 -> {ok, prim_buffer:read(Buffer, Size)}; + Size when Size =:= 0 -> eof + end; + Error -> + Error + end; +read_line_1(Data, Buffer, {ok, LFIndex}) -> + %% Translate CRLF into just LF, completely ignoring which encoding is used, + %% but treat the file position as including CR. + #{ position := Position } = Data, + NewData = Data#{ position => (Position + LFIndex + 1) }, + CRIndex = (LFIndex - 1), + TranslatedLine = + case prim_buffer:read(Buffer, LFIndex + 1) of + <<Line:CRIndex/binary, "\r\n">> -> <<Line/binary, "\n">>; + Line -> Line + end, + {ok, NewData, TranslatedLine}. + +%% +%% We support seeking in both directions as long as it isn't relative to EOF. +%% +%% Seeking backwards is extremely inefficient since we have to seek to the very +%% beginning and then decompress up to the desired point. +%% + +position(Data, Mark) when is_atom(Mark) -> + position(Data, {Mark, 0}); +position(Data, Offset) when is_integer(Offset) -> + position(Data, {bof, Offset}); +position(Data, {bof, Offset}) when is_integer(Offset) -> + position_1(Data, Offset); +position(Data, {cur, Offset}) when is_integer(Offset) -> + #{ position := Position } = Data, + position_1(Data, Position + Offset); +position(_Data, {eof, Offset}) when is_integer(Offset) -> + {error, einval}; +position(_Data, _Other) -> + {error, badarg}. + +position_1(_Data, Desired) when Desired < 0 -> + {error, einval}; +position_1(#{ position := Desired } = Data, Desired) -> + {ok, Data, Desired}; +position_1(#{ position := Current } = Data, Desired) when Current < Desired -> + case read(Data, min(Desired - Current, ?INFLATE_CHUNK_SIZE)) of + {ok, NewData, _Data} -> position_1(NewData, Desired); + eof -> {ok, Data, Current}; + Other -> Other + end; +position_1(#{ position := Current } = Data, Desired) when Current > Desired -> + #{ handle := PrivateFd, buffer := Buffer, zlib := Z } = Data, + case ?CALL_FD(PrivateFd, position, [bof]) of + {ok, 0} -> + ok = zlib:inflateReset(Z), + prim_buffer:wipe(Buffer), + position_1(Data#{ position => 0 }, Desired); + Other -> + Other + end. + +terminate(_Reason, _State, _Data) -> + ok. diff --git a/lib/kernel/src/raw_file_io_list.erl b/lib/kernel/src/raw_file_io_list.erl new file mode 100644 index 0000000000..2e16e63f0e --- /dev/null +++ b/lib/kernel/src/raw_file_io_list.erl @@ -0,0 +1,128 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. 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(raw_file_io_list). + +-export([close/1, sync/1, datasync/1, truncate/1, advise/4, allocate/3, + position/2, write/2, pwrite/2, pwrite/3, + read_line/1, read/2, pread/2, pread/3]). + +%% OTP internal. +-export([ipread_s32bu_p32bu/3, sendfile/8]). + +-export([open_layer/3]). + +-include("file_int.hrl"). + +open_layer(Filename, Modes, [list]) -> + case raw_file_io:open(Filename, [binary | Modes]) of + {ok, PrivateFd} -> {ok, make_public_fd(PrivateFd, Modes)}; + Other -> Other + end. + +%% We can skip wrapping the file if it's write-only since only read operations +%% are affected by list mode. Since raw_file_io fills in all implicit options +%% for us, all we need to do is check whether 'read' is among them. +make_public_fd(PrivateFd, Modes) -> + case lists:member(read, Modes) of + true -> #file_descriptor{ module = ?MODULE, data = PrivateFd }; + false -> PrivateFd + end. + +close(Fd) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, close, []). + +sync(Fd) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, sync, []). +datasync(Fd) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, datasync, []). + +truncate(Fd) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, truncate, []). + +advise(Fd, Offset, Length, Advise) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, advise, [Offset, Length, Advise]). +allocate(Fd, Offset, Length) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, allocate, [Offset, Length]). + +position(Fd, Mark) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, position, [Mark]). + +write(Fd, IOData) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, write, [IOData]). + +pwrite(Fd, Offset, IOData) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, pwrite, [Offset, IOData]). +pwrite(Fd, LocBytes) -> + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, pwrite, [LocBytes]). + +read_line(Fd) -> + PrivateFd = Fd#file_descriptor.data, + case ?CALL_FD(PrivateFd, read_line, []) of + {ok, Binary} -> {ok, binary_to_list(Binary)}; + Other -> Other + end. +read(Fd, Size) -> + PrivateFd = Fd#file_descriptor.data, + case ?CALL_FD(PrivateFd, read, [Size]) of + {ok, Binary} -> {ok, binary_to_list(Binary)}; + Other -> Other + end. +pread(Fd, Offset, Size) -> + PrivateFd = Fd#file_descriptor.data, + case ?CALL_FD(PrivateFd, pread, [Offset, Size]) of + {ok, Binary} -> {ok, binary_to_list(Binary)}; + Other -> Other + end. +pread(Fd, LocNums) -> + PrivateFd = Fd#file_descriptor.data, + case ?CALL_FD(PrivateFd, pread, [LocNums]) of + {ok, LocResults} -> + TranslatedResults = + [ case Result of + Result when is_binary(Result) -> binary_to_list(Result); + eof -> eof + end || Result <- LocResults ], + {ok, TranslatedResults}; + Other -> Other + end. + +ipread_s32bu_p32bu(Fd, Offset, MaxSize) -> + PrivateFd = Fd#file_descriptor.data, + case ?CALL_FD(PrivateFd, ipread_s32bu_p32bu, [Offset, MaxSize]) of + {ok, {Size, Pointer, Binary}} when is_binary(Binary) -> + {ok, {Size, Pointer, binary_to_list(Binary)}}; + Other -> + Other + end. + +sendfile(Fd, Dest, Offset, Bytes, ChunkSize, Headers, Trailers, Flags) -> + Args = [Dest, Offset, Bytes, ChunkSize, Headers, Trailers, Flags], + PrivateFd = Fd#file_descriptor.data, + ?CALL_FD(PrivateFd, sendfile, Args). diff --git a/lib/kernel/src/raw_file_io_raw.erl b/lib/kernel/src/raw_file_io_raw.erl new file mode 100644 index 0000000000..9a9fe78eb1 --- /dev/null +++ b/lib/kernel/src/raw_file_io_raw.erl @@ -0,0 +1,25 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. 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(raw_file_io_raw). + +-export([open_layer/3]). + +open_layer(Filename, Modes, [raw]) -> + prim_file:open(Filename, [raw | Modes]). diff --git a/lib/kernel/test/disk_log_SUITE.erl b/lib/kernel/test/disk_log_SUITE.erl index fe2fc778f2..0709a6e766 100644 --- a/lib/kernel/test/disk_log_SUITE.erl +++ b/lib/kernel/test/disk_log_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2017. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. @@ -89,8 +89,6 @@ dist_terminate/1, dist_accessible/1, dist_deadlock/1, dist_open2/1, other_groups/1, - evil/1, - otp_6278/1, otp_10131/1]). -export([head_fun/1, hf/0, lserv/1, @@ -123,7 +121,7 @@ [halt_int, wrap_int, halt_ext, wrap_ext, read_mode, head, notif, new_idx_vsn, reopen, block, unblock, open, close, error, chunk, truncate, many_users, info, change_size, - change_attribute, distribution, evil, otp_6278, otp_10131]). + change_attribute, distribution, otp_6278, otp_10131]). %% These test cases should be skipped if the VxWorks card is %% configured without NFS cache. @@ -149,7 +147,7 @@ all() -> {group, open}, {group, close}, {group, error}, chunk, truncate, many_users, {group, info}, {group, change_size}, change_attribute, - {group, distribution}, evil, otp_6278, otp_10131]. + {group, distribution}, otp_6278, otp_10131]. groups() -> [{halt_int, [], [halt_int_inf, {group, halt_int_sz}]}, @@ -4676,119 +4674,6 @@ other_groups(Conf) when is_list(Conf) -> ok. --define(MAX, ?MAX_FWRITE_CACHE). % as in disk_log_1.erl -%% Evil cases such as closed file descriptor port. -evil(Conf) when is_list(Conf) -> - Dir = ?privdir(Conf), - File = filename:join(Dir, "n.LOG"), - Log = n, - - %% Not a very thorough test. - - ok = setup_evil_filled_cache_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:log(Log, apa), - ok = disk_log:close(Log), - - ok = setup_evil_filled_cache_halt(Log, Dir), - {error, {file_error,_,einval}} = disk_log:truncate(Log, apa), - ok = stop_evil(Log), - - %% White box test. - file:delete(File), - Ports0 = erlang:ports(), - {ok, Log} = disk_log:open([{name,Log},{file,File},{type,halt}, - {size,?MAX+50},{format,external}]), - [Fd] = erlang:ports() -- Ports0, - {B,_} = x_mk_bytes(30), - ok = disk_log:blog(Log, <<0:(?MAX-1)/unit:8>>), - exit(Fd, kill), - {error, {file_error,_,einval}} = disk_log:blog_terms(Log, [B,B]), - ok= disk_log:close(Log), - file:delete(File), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:close(Log), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:log(Log, apa), - ok = stop_evil(Log), - - ok = setup_evil_halt(Log, Dir), - {error, {file_error,_,einval}} = disk_log:log(Log, apa), - ok = stop_evil(Log), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:reopen(Log, apa), - {error, {file_error,_,einval}} = disk_log:reopen(Log, apa), - ok = stop_evil(Log), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:reopen(Log, apa), - ok = stop_evil(Log), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:inc_wrap_file(Log), - ok = stop_evil(Log), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:chunk(Log, start), - ok = stop_evil(Log), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:truncate(Log), - ok = stop_evil(Log), - - ok = setup_evil_wrap(Log, Dir), - {error, {file_error,_,einval}} = disk_log:chunk_step(Log, start, 1), - ok = stop_evil(Log), - - io:format("messages: ~p~n", [erlang:process_info(self(), messages)]), - del(File, 2), - file:delete(File), - ok. - -setup_evil_wrap(Log, Dir) -> - setup_evil(Log, [{type,wrap},{size,{100,2}}], Dir). - -setup_evil_halt(Log, Dir) -> - setup_evil(Log, [{type,halt},{size,10000}], Dir). - -setup_evil(Log, Args, Dir) -> - File = filename:join(Dir, lists:concat([Log, ".LOG"])), - file:delete(File), - del(File, 2), - ok = disk_log:start(), - Ports0 = erlang:ports(), - {ok, Log} = disk_log:open([{name,Log},{file,File} | Args]), - [Fd] = erlang:ports() -- Ports0, - exit(Fd, kill), - ok = disk_log:log_terms(n, [<<0:10/unit:8>>]), - timer:sleep(2500), % TIMEOUT in disk_log_1.erl is 2000 - ok. - -stop_evil(Log) -> - {error, _} = disk_log:close(Log), - ok. - -setup_evil_filled_cache_wrap(Log, Dir) -> - setup_evil_filled_cache(Log, [{type,wrap},{size,{?MAX,2}}], Dir). - -setup_evil_filled_cache_halt(Log, Dir) -> - setup_evil_filled_cache(Log, [{type,halt},{size,infinity}], Dir). - -%% The cache is filled, and the file descriptor port gone. -setup_evil_filled_cache(Log, Args, Dir) -> - File = filename:join(Dir, lists:concat([Log, ".LOG"])), - file:delete(File), - del(File, 2), - ok = disk_log:start(), - Ports0 = erlang:ports(), - {ok, Log} = disk_log:open([{name,Log},{file,File} | Args]), - [Fd] = erlang:ports() -- Ports0, - ok = disk_log:log_terms(n, [<<0:?MAX/unit:8>>]), - exit(Fd, kill), - ok. - %% OTP-6278. open/1 creates no status or crash report. otp_6278(Conf) when is_list(Conf) -> Dir = ?privdir(Conf), diff --git a/lib/kernel/test/erl_distribution_wb_SUITE.erl b/lib/kernel/test/erl_distribution_wb_SUITE.erl index 03aaee56b7..8256444bdc 100644 --- a/lib/kernel/test/erl_distribution_wb_SUITE.erl +++ b/lib/kernel/test/erl_distribution_wb_SUITE.erl @@ -61,10 +61,13 @@ %% From R9 and forward extended references is compulsory %% From R10 and forward extended pids and ports are compulsory %% From R20 and forward UTF8 atoms are compulsory +%% From R21 and forward NEW_FUN_TAGS is compulsory (no more tuple fallback {fun, ...}) -define(COMPULSORY_DFLAGS, (?DFLAG_EXTENDED_REFERENCES bor ?DFLAG_EXTENDED_PIDS_PORTS bor - ?DFLAG_UTF8_ATOMS)). + ?DFLAG_UTF8_ATOMS bor + ?DFLAG_NEW_FUN_TAGS)). +-define(PASS_THROUGH, $p). -define(shutdown(X), exit(X)). -define(int16(X), [((X) bsr 8) band 16#ff, (X) band 16#ff]). @@ -674,15 +677,16 @@ build_rex_message(Cookie,OurName) -> %% Receive a distribution message recv_message(Socket) -> case gen_tcp:recv(Socket, 0) of + {ok,[]} -> + recv_message(Socket); %% a tick, ignore {ok,Data} -> B0 = list_to_binary(Data), - {_,B1} = erlang:split_binary(B0,1), - Header = binary_to_term(B1), - Siz = byte_size(term_to_binary(Header)), - {_,B2} = erlang:split_binary(B1,Siz), + <<?PASS_THROUGH, B1/binary>> = B0, + {Header,Siz} = binary_to_term(B1,[used]), + <<_:Siz/binary,B2/binary>> = B1, Message = case (catch binary_to_term(B2)) of {'EXIT', _} -> - could_not_digest_message; + {could_not_digest_message,B2}; Other -> Other end, diff --git a/lib/kernel/test/erl_prim_loader_SUITE.erl b/lib/kernel/test/erl_prim_loader_SUITE.erl index b6417210b9..3502a4ad08 100644 --- a/lib/kernel/test/erl_prim_loader_SUITE.erl +++ b/lib/kernel/test/erl_prim_loader_SUITE.erl @@ -33,6 +33,7 @@ primary_archive/1, virtual_dir_in_archive/1, get_modules/1]). +-define(PRIM_FILE, prim_file). %%----------------------------------------------------------------- %% Test suite for erl_prim_loader. (Most code is run during system start/stop.) @@ -461,7 +462,7 @@ primary_archive(Config) when is_list(Config) -> %% Set primary archive ExpectedEbins = [Archive, DictDir ++ "/ebin", DummyDir ++ "/ebin"], io:format("ExpectedEbins: ~p\n", [ExpectedEbins]), - {ok, FileInfo} = prim_file:read_file_info(Archive), + {ok, FileInfo} = ?PRIM_FILE:read_file_info(Archive), {ok, Ebins} = rpc:call(Node, erl_prim_loader, set_primary_archive, [Archive, ArchiveBin, FileInfo, fun escript:parse_file/1]), diff --git a/lib/kernel/test/file_SUITE.erl b/lib/kernel/test/file_SUITE.erl index 119e1f24bb..0cb8087a76 100644 --- a/lib/kernel/test/file_SUITE.erl +++ b/lib/kernel/test/file_SUITE.erl @@ -39,6 +39,8 @@ -define(FILE_FIN_PER_TESTCASE(Config), Config). -endif. +-define(PRIM_FILE, prim_file). + -module(?FILE_SUITE). -export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, @@ -97,6 +99,12 @@ -export([unicode_mode/1]). +-export([volume_relative_paths/1]). + +-export([tiny_writes/1, tiny_writes_delayed/1, + large_writes/1, large_writes_delayed/1, + tiny_reads/1, tiny_reads_ahead/1]). + %% Debug exports -export([create_file_slow/2, create_file/2, create_bin/2]). -export([verify_file/2, verify_bin/3]). @@ -107,6 +115,8 @@ -export([disc_free/1, memsize/0]). -include_lib("common_test/include/ct.hrl"). +-include_lib("common_test/include/ct_event.hrl"). + -include_lib("kernel/include/file.hrl"). -define(THROW_ERROR(RES), throw({fail, ?LINE, RES})). @@ -118,13 +128,13 @@ suite() -> all() -> [unicode, altname, read_write_file, {group, dirs}, - {group, files}, delete, rename, names, {group, errors}, - {group, compression}, {group, links}, copy, + {group, files}, delete, rename, names, volume_relative_paths, + {group, errors}, {group, compression}, {group, links}, copy, delayed_write, read_ahead, segment_read, segment_write, ipread, pid2name, interleaved_read_write, otp_5814, otp_10852, large_file, large_write, read_line_1, read_line_2, read_line_3, read_line_4, standard_io, old_io_protocol, - unicode_mode + unicode_mode, {group, bench} ]. groups() -> @@ -154,11 +164,19 @@ groups() -> write_compressed, compress_errors, catenated_gzips, compress_async_crash]}, {links, [], - [make_link, read_link_info_for_non_link, symlinks]}]. + [make_link, read_link_info_for_non_link, symlinks]}, + {bench, [], + [tiny_writes, tiny_writes_delayed, + large_writes, large_writes_delayed, + tiny_reads, tiny_reads_ahead]}]. init_per_group(_GroupName, Config) -> Config. +end_per_group(bench, Config) -> + ScratchDir = proplists:get_value(priv_dir, Config), + file:delete(filename:join(ScratchDir, "benchmark_scratch_file")), + Config; end_per_group(_GroupName, Config) -> Config. @@ -473,7 +491,7 @@ um_check_unicode(_Utf8Bin, {ok, _ListOrBin}, _, _UTF8_) -> um_filename(Bin, Dir, Options) when is_binary(Bin) -> um_filename(binary_to_list(Bin), Dir, Options); um_filename(Str = [_|_], Dir, Options) -> - Name = hd(string:tokens(Str, ":")), + Name = hd(string:lexemes(Str, ":")), Enc = atom_to_list(proplists:get_value(encoding, Options, latin1)), File = case lists:member(binary, Options) of true -> @@ -638,6 +656,10 @@ cur_dir_0(Config) when is_list(Config) -> {ok,NewDirFiles} = ?FILE_MODULE:list_dir("."), true = lists:member(UncommonName,NewDirFiles), + %% Ensure that we get the same result with a trailing slash; the + %% APIs used on Windows will choke on them if passed directly. + {ok,NewDirFiles} = ?FILE_MODULE:list_dir("./"), + %% Delete the directory and return to the old current directory %% and check that the created file isn't there (too!) expect({error, einval}, {error, eacces}, @@ -690,10 +712,15 @@ win_cur_dir_1(_Config) -> %% Get the drive letter from the current directory, %% and try to get current directory for that drive. - [Drive,$:|_] = BaseDir, - {ok,BaseDir} = ?FILE_MODULE:get_cwd([Drive,$:]), + [CurDrive,$:|_] = BaseDir, + {ok,BaseDir} = ?FILE_MODULE:get_cwd([CurDrive,$:]), io:format("BaseDir = ~s\n", [BaseDir]), + %% We should error out on non-existent drives. Any reasonable system will + %% have at least one. + CurDirs = [?FILE_MODULE:get_cwd([Drive,$:]) || Drive <- lists:seq($A, $Z)], + lists:member({error,eaccess}, CurDirs), + %% Unfortunately, there is no way to move away from the %% current drive as we can't use the "subst" command from %% a SSH connection. We can't test any more. @@ -831,7 +858,7 @@ no_untranslatable_names() -> end. start_node(Name, Args) -> - [_,Host] = string:tokens(atom_to_list(node()), "@"), + [_,Host] = string:lexemes(atom_to_list(node()), "@"), ct:log("Trying to start ~w@~s~n", [Name,Host]), case test_server:start_node(Name, peer, [{args,Args}]) of {error,Reason} -> @@ -1019,6 +1046,23 @@ close(Config) when is_list(Config) -> Val = ?FILE_MODULE:close(Fd1), io:format("Second close gave: ~p",[Val]), + %% All operations on a closed raw file should EINVAL, even if they're not + %% supported on the current platform. + {ok,Fd2} = ?FILE_MODULE:open(Name, [read, write, raw]), + ok = ?FILE_MODULE:close(Fd2), + + {error, einval} = ?FILE_MODULE:advise(Fd2, 5, 5, normal), + {error, einval} = ?FILE_MODULE:allocate(Fd2, 5, 5), + {error, einval} = ?FILE_MODULE:close(Fd2), + {error, einval} = ?FILE_MODULE:datasync(Fd2), + {error, einval} = ?FILE_MODULE:position(Fd2, 5), + {error, einval} = ?FILE_MODULE:pread(Fd2, 5, 1), + {error, einval} = ?FILE_MODULE:pwrite(Fd2, 5, "einval please"), + {error, einval} = ?FILE_MODULE:read(Fd2, 1), + {error, einval} = ?FILE_MODULE:sync(Fd2), + {error, einval} = ?FILE_MODULE:truncate(Fd2), + {error, einval} = ?FILE_MODULE:write(Fd2, "einval please"), + [] = flush(), ok. @@ -1132,8 +1176,8 @@ pread_write_test(File, Data) -> end, I = Size + 17, ok = ?FILE_MODULE:pwrite(File, 0, Data), - Res = ?FILE_MODULE:pread(File, 0, I), - {ok, Data} = Res, + {ok, Data} = ?FILE_MODULE:pread(File, 0, I), + {ok, [Data]} = ?FILE_MODULE:pread(File, [{0, I}]), eof = ?FILE_MODULE:pread(File, I, 1), ok = ?FILE_MODULE:pwrite(File, [{0, Data}, {I, Data}]), {ok, [Data, eof, Data]} = @@ -2044,13 +2088,22 @@ names(Config) when is_list(Config) -> ok = ?FILE_MODULE:close(Fd2), {ok,Fd3} = ?FILE_MODULE:open(Name3,read), ok = ?FILE_MODULE:close(Fd3), + + %% Now try the same on raw files. + {ok,Fd4} = ?FILE_MODULE:open(Name2, [read, raw]), + ok = ?FILE_MODULE:close(Fd4), + {ok,Fd4f} = ?FILE_MODULE:open(lists:flatten(Name2), [read, raw]), + ok = ?FILE_MODULE:close(Fd4f), + {ok,Fd5} = ?FILE_MODULE:open(Name3, [read, raw]), + ok = ?FILE_MODULE:close(Fd5), + case length(Name1) > 255 of true -> io:format("Path too long for an atom:\n\n~p\n", [Name1]); false -> Name4 = list_to_atom(Name1), - {ok,Fd4} = ?FILE_MODULE:open(Name4,read), - ok = ?FILE_MODULE:close(Fd4) + {ok,Fd6} = ?FILE_MODULE:open(Name4,read), + ok = ?FILE_MODULE:close(Fd6) end, %% Try some path names @@ -2074,6 +2127,22 @@ names(Config) when is_list(Config) -> [] = flush(), ok. +volume_relative_paths(Config) when is_list(Config) -> + case os:type() of + {win32, _} -> + {ok, [Drive, $: | _]} = file:get_cwd(), + %% Relative to current device root. + {ok, RootInfo} = file:read_file_info([Drive, $:, $/]), + {ok, RootInfo} = file:read_file_info("/"), + %% Relative to current device directory. + {ok, DirContents} = file:list_dir([Drive, $:]), + {ok, DirContents} = file:list_dir("."), + [] = flush(), + ok; + _ -> + {skip, "This test is Windows-specific."} + end. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -2641,8 +2710,8 @@ altname(Config) when is_list(Config) -> {skipped, "Altname not supported on this platform"}; {ok, "LONGAL~1"} -> {ok, "A_FILE~1"} = ?FILE_MODULE:altname(Name), - {ok, "C:/"} = ?FILE_MODULE:altname("C:/"), - {ok, "C:\\"} = ?FILE_MODULE:altname("C:\\"), + {ok, "c:/"} = ?FILE_MODULE:altname("C:/"), + {ok, "c:/"} = ?FILE_MODULE:altname("C:\\"), {error,enoent} = ?FILE_MODULE:altname(NonexName), {ok, "short"} = ?FILE_MODULE:altname(ShortName), ok @@ -2923,20 +2992,22 @@ delayed_write(Config) when is_list(Config) -> %% %% Test caching and normal close of non-raw file {ok, Fd1} = - ?FILE_MODULE:open(File, [write, {delayed_write, Size+1, 2000}]), + ?FILE_MODULE:open(File, [write, {delayed_write, Size+1, 400}]), ok = ?FILE_MODULE:write(Fd1, Data1), - timer:sleep(1000), % Just in case the file system is slow + %% Wait for a reasonable amount of time to check whether the write was + %% practically instantaneous or actually delayed. + timer:sleep(100), {ok, Fd2} = ?FILE_MODULE:open(File, [read]), eof = ?FILE_MODULE:read(Fd2, 1), ok = ?FILE_MODULE:write(Fd1, Data1), % Data flush on size - timer:sleep(1000), % Just in case the file system is slow + timer:sleep(100), {ok, Data1Data1} = ?FILE_MODULE:pread(Fd2, bof, 2*Size+1), ok = ?FILE_MODULE:write(Fd1, Data1), - timer:sleep(3000), % Wait until data flush on timeout + timer:sleep(500), % Wait until data flush on timeout {ok, Data1Data1Data1} = ?FILE_MODULE:pread(Fd2, bof, 3*Size+1), ok = ?FILE_MODULE:write(Fd1, Data1), ok = ?FILE_MODULE:close(Fd1), % Data flush on close - timer:sleep(1000), % Just in case the file system is slow + timer:sleep(100), {ok, Data1Data1Data1Data1} = ?FILE_MODULE:pread(Fd2, bof, 4*Size+1), ok = ?FILE_MODULE:close(Fd2), %% @@ -2970,7 +3041,7 @@ delayed_write(Config) when is_list(Config) -> {'DOWN', Mref1, _, _, _} = Down1a -> ct:fail(Down1a) end, - timer:sleep(1000), % Just in case the file system is slow + timer:sleep(100), % Just in case the file system is slow {ok, Fd3} = ?FILE_MODULE:open(File, [read]), eof = ?FILE_MODULE:read(Fd3, 1), Child1 ! {Parent, continue, normal}, @@ -2980,7 +3051,7 @@ delayed_write(Config) when is_list(Config) -> {'DOWN', Mref1, _, _, _} = Down1b -> ct:fail(Down1b) end, - timer:sleep(1000), % Just in case the file system is slow + timer:sleep(100), % Just in case the file system is slow {ok, Data1} = ?FILE_MODULE:pread(Fd3, bof, Size+1), ok = ?FILE_MODULE:close(Fd3), %% @@ -2993,7 +3064,7 @@ delayed_write(Config) when is_list(Config) -> {'DOWN', Mref2, _, _, _} = Down2a -> ct:fail(Down2a) end, - timer:sleep(1000), % Just in case the file system is slow + timer:sleep(100), % Just in case the file system is slow {ok, Fd4} = ?FILE_MODULE:open(File, [read]), eof = ?FILE_MODULE:read(Fd4, 1), Child2 ! {Parent, continue, kill}, @@ -3003,7 +3074,7 @@ delayed_write(Config) when is_list(Config) -> {'DOWN', Mref2, _, _, _} = Down2b -> ct:fail(Down2b) end, - timer:sleep(1000), % Just in case the file system is slow + timer:sleep(100), % Just in case the file system is slow eof = ?FILE_MODULE:pread(Fd4, bof, 1), ok = ?FILE_MODULE:close(Fd4), %% @@ -3095,6 +3166,16 @@ read_ahead(Config) when is_list(Config) -> Data1Data2Data3 = Data1++Data2++Data3, {ok, Data1Data2Data3} = ?FILE_MODULE:read(Fd5, 3*Size+1), ok = ?FILE_MODULE:close(Fd5), + + %% Ensure that a read that draws from both the buffer and the file won't + %% return anything wonky. + SplitData = << <<(I rem 256)>> || I <- lists:seq(1, 1024) >>, + file:write_file(File, SplitData), + {ok, Fd6} = ?FILE_MODULE:open(File, [raw, read, binary, {read_ahead, 256}]), + {ok, <<1>>} = file:read(Fd6, 1), + <<1, Shifted:512/binary, _Rest/binary>> = SplitData, + {ok, Shifted} = file:read(Fd6, 512), + %% [] = flush(), ok. @@ -3699,6 +3780,83 @@ do_large_write(Name) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Benchmarks +%% +%% Note that we only measure the time it takes to run the isolated file +%% operations and that the actual test runtime can differ significantly, +%% especially on the write side as the files need to be truncated before +%% writing. + +large_writes(Config) when is_list(Config) -> + Modes = [raw, binary], + OpCount = 4096, + Data = <<0:(64 bsl 10)/unit:8>>, + run_write_benchmark(Config, Modes, OpCount, Data). + +large_writes_delayed(Config) when is_list(Config) -> + %% Each write is exactly as large as the delay buffer, causing the writes + %% to pass through each time, giving us a decent idea of how much overhead + %% delayed_write adds. + Modes = [raw, binary, {delayed_write, 64 bsl 10, 2000}], + OpCount = 4096, + Data = <<0:(64 bsl 10)/unit:8>>, + run_write_benchmark(Config, Modes, OpCount, Data). + +tiny_writes(Config) when is_list(Config) -> + Modes = [raw, binary], + OpCount = 512 bsl 10, + Data = <<0>>, + run_write_benchmark(Config, Modes, OpCount, Data). + +tiny_writes_delayed(Config) when is_list(Config) -> + Modes = [raw, binary, {delayed_write, 512 bsl 10, 2000}], + OpCount = 512 bsl 10, + Data = <<0>>, + run_write_benchmark(Config, Modes, OpCount, Data). + +%% The read benchmarks assume that "benchmark_scratch_file" has been filled by +%% the write benchmarks. + +tiny_reads(Config) when is_list(Config) -> + Modes = [raw, binary], + OpCount = 512 bsl 10, + run_read_benchmark(Config, Modes, OpCount, 1). + +tiny_reads_ahead(Config) when is_list(Config) -> + Modes = [raw, binary, {read_ahead, 512 bsl 10}], + OpCount = 512 bsl 10, + run_read_benchmark(Config, Modes, OpCount, 1). + +run_write_benchmark(Config, Modes, OpCount, Data) -> + run_benchmark(Config, [write | Modes], OpCount, fun file:write/2, Data). + +run_read_benchmark(Config, Modes, OpCount, OpSize) -> + run_benchmark(Config, [read | Modes], OpCount, fun file:read/2, OpSize). + +run_benchmark(Config, Modes, OpCount, Fun, Arg) -> + ScratchDir = proplists:get_value(priv_dir, Config), + Path = filename:join(ScratchDir, "benchmark_scratch_file"), + {ok, Fd} = file:open(Path, Modes), + submit_throughput_results(Fun, [Fd, Arg], OpCount). + +submit_throughput_results(Fun, Args, Times) -> + MSecs = measure_repeated_file_op(Fun, Args, Times, millisecond), + IOPS = trunc(Times * (1000 / MSecs)), + ct_event:notify(#event{ name = benchmark_data, data = [{value,IOPS}] }), + {comment, io_lib:format("~p IOPS, ~p ms", [IOPS, trunc(MSecs)])}. + +measure_repeated_file_op(Fun, Args, Times, Unit) -> + Start = os:perf_counter(Unit), + repeated_apply(Fun, Args, Times), + os:perf_counter(Unit) - Start. + +repeated_apply(_F, _Args, Times) when Times =< 0 -> + ok; +repeated_apply(F, Args, Times) -> + erlang:apply(F, Args), + repeated_apply(F, Args, Times - 1). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% response_analysis(Module, Function, Arguments) -> @@ -3934,7 +4092,7 @@ read_line_create_files(TestData) -> read_line_remove_files(TestData) -> [ file:delete(File) || {_Function,File,_,_} <- TestData ]. -%% read_line with prim_file. +%% read_line with ?PRIM_FILE. read_line_1(Config) when is_list(Config) -> PrivDir = proplists:get_value(priv_dir, Config), All = read_line_testdata(PrivDir), @@ -4103,9 +4261,9 @@ read_line_create7(Filename) -> file:close(F). read_line_all(Filename) -> - {ok,F} = prim_file:open(Filename,[read,binary]), + {ok,F} = ?PRIM_FILE:open(Filename,[read,binary]), X=read_rl_lines(F), - prim_file:close(F), + ?PRIM_FILE:close(F), Bin = list_to_binary([B || {ok,B} <- X]), Bin = re:replace(list_to_binary([element(2,file:read_file(Filename))]), "\r\n","\n",[global,{return,binary}]), @@ -4138,7 +4296,7 @@ read_line_all4(Filename) -> {length(X),Bin}. read_rl_lines(F) -> - case prim_file:read_line(F) of + case ?PRIM_FILE:read_line(F) of eof -> []; {error,X} -> @@ -4158,9 +4316,9 @@ read_rl_lines2(F) -> end. read_line_all_alternating(Filename) -> - {ok,F} = prim_file:open(Filename,[read,binary]), + {ok,F} = ?PRIM_FILE:open(Filename,[read,binary]), X=read_rl_lines(F,true), - prim_file:close(F), + ?PRIM_FILE:close(F), Bin = list_to_binary([B || {ok,B} <- X]), Bin = re:replace(list_to_binary([element(2,file:read_file(Filename))]), "\r\n","\n",[global,{return,binary}]), @@ -4194,8 +4352,8 @@ read_line_all_alternating4(Filename) -> read_rl_lines(F,Alternate) -> case begin case Alternate of - true -> prim_file:read(F,1); - false -> prim_file:read_line(F) + true -> ?PRIM_FILE:read(F,1); + false -> ?PRIM_FILE:read_line(F) end end of eof -> diff --git a/lib/kernel/test/file_name_SUITE.erl b/lib/kernel/test/file_name_SUITE.erl index f23529fec9..3afc647081 100644 --- a/lib/kernel/test/file_name_SUITE.erl +++ b/lib/kernel/test/file_name_SUITE.erl @@ -77,6 +77,7 @@ init_per_testcase/2, end_per_testcase/2]). -export([normal/1,icky/1,very_icky/1,normalize/1,home_dir/1]). +-define(PRIM_FILE, prim_file). init_per_testcase(_Func, Config) -> Config. @@ -131,7 +132,7 @@ home_dir(Config) when is_list(Config) -> os:putenv("HOME",NewHome), {"HOME",Save}; _ -> - rm_rf(prim_file,NewHome), + rm_rf(?PRIM_FILE,NewHome), throw(unsupported_os) end, try @@ -145,7 +146,7 @@ home_dir(Config) when is_list(Config) -> _ -> os:putenv(SaveOldName,SaveOldValue) end, - rm_rf(prim_file,NewHome) + rm_rf(?PRIM_FILE,NewHome) end catch throw:need_unicode_mode -> @@ -190,7 +191,7 @@ normal(Config) when is_list(Config) -> try Priv = proplists:get_value(priv_dir, Config), file:set_cwd(Priv), - ok = check_normal(prim_file), + ok = check_normal(?PRIM_FILE), ok = check_normal(file), %% If all is good, delete dir again (avoid hanging dir on windows) rm_rf(file,"normal_dir"), @@ -210,7 +211,7 @@ icky(Config) when is_list(Config) -> try Priv = proplists:get_value(priv_dir, Config), file:set_cwd(Priv), - ok = check_icky(prim_file), + ok = check_icky(?PRIM_FILE), ok = check_icky(file), %% If all is good, delete dir again (avoid hanging dir on windows) rm_rf(file,"icky_dir"), @@ -229,7 +230,7 @@ very_icky(Config) when is_list(Config) -> try Priv = proplists:get_value(priv_dir, Config), file:set_cwd(Priv), - case check_very_icky(prim_file) of + case check_very_icky(?PRIM_FILE) of need_unicode_mode -> {skipped,"VM needs to be started in Unicode filename mode"}; ok -> @@ -292,11 +293,6 @@ check_normal(Mod) -> ok end, [ begin - {ok, FD} = Mod:open(Name,[read]), - {ok, Content} = Mod:read(FD,1024), - ok = file:close(FD) - end || {regular,Name,Content} <- NormalDir ], - [ begin {ok, FD} = Mod:open(Name,[read,binary]), BC = list_to_binary(Content), {ok, BC} = Mod:read(FD,1024), @@ -412,11 +408,6 @@ check_icky(Mod) -> ok end, [ begin - {ok, FD} = Mod:open(Name,[read]), - {ok, Content} = Mod:read(FD,1024), - ok = file:close(FD) - end || {regular,Name,Content} <- IckyDir ], - [ begin {ok, FD} = Mod:open(Name,[read,binary]), BC = list_to_binary([Content]), {ok, BC} = Mod:read(FD,1024), @@ -521,11 +512,6 @@ check_very_icky(Mod) -> ok end, [ begin - {ok, FD} = Mod:open(Name,[read]), - {ok, Content} = Mod:read(FD,1024), - ok = file:close(FD) - end || {regular,Name,Content} <- VeryIckyDir ], - [ begin {ok, FD} = Mod:open(Name,[read,binary]), BC = list_to_binary([Content]), {ok, BC} = Mod:read(FD,1024), diff --git a/lib/kernel/test/gen_tcp_misc_SUITE.erl b/lib/kernel/test/gen_tcp_misc_SUITE.erl index 331864b5de..e47023d201 100644 --- a/lib/kernel/test/gen_tcp_misc_SUITE.erl +++ b/lib/kernel/test/gen_tcp_misc_SUITE.erl @@ -1572,52 +1572,56 @@ fill_sendq(Config) when is_list(Config) -> Master = self(), Server = spawn_link(fun () -> - {ok,L} = gen_tcp:listen - (0, [{active,false},binary, - {reuseaddr,true},{packet,0}]), + {ok,L} = gen_tcp:listen(0, [{active,false},binary, + {reuseaddr,true},{packet,0}]), {ok,Port} = inet:port(L), Master ! {self(),client, fill_sendq_client(Port, Master)}, fill_sendq_srv(L, Master) end), io:format("~p Server~n", [Server]), - receive {Server,client,Client} -> - io:format("~p Client~n", [Client]), - receive {Server,reader,Reader} -> - io:format("~p Reader~n", [Reader]), - fill_sendq_loop(Server, Client, Reader) + receive + {Server,client,Client} -> + io:format("~p Client~n", [Client]), + receive + {Server,reader,Reader} -> + io:format("~p Reader~n", [Reader]), + fill_sendq_loop(Server, Client, Reader) end end. fill_sendq_loop(Server, Client, Reader) -> %% Master %% - receive {Server,send} -> + receive + {Server,send} -> fill_sendq_loop(Server, Client, Reader) after 2000 -> %% Send queue full, sender blocked -> close client. io:format("Send timeout, closing Client...~n", []), Client ! {self(),close}, - receive {Server,[{error,closed}]} -> - io:format("Got server closed.~n"), - receive {Reader,[{error,closed}]} -> - io:format - ("Got reader closed.~n"), - ok - after 3000 -> - ct:fail({timeout,{closed,reader}}) - end; - {Reader,[{error,closed}]} -> - io:format("Got reader closed.~n"), - receive {Server,[{error,closed}]} -> - io:format("Got server closed~n"), - ok - after 3000 -> - ct:fail({timeout,{closed,server}}) - end - after 3000 -> - ct:fail({timeout,{closed,[server,reader]}}) - end + receive + {Server,[{error,closed}]} -> + io:format("Got server closed.~n"), + receive + {Reader,[{error,closed}]} -> + io:format("Got reader closed.~n"), + ok + after 3000 -> + ct:fail({timeout,{closed,reader}}) + end; + {Reader,[{error,closed}]} -> + io:format("Got reader closed.~n"), + receive + {Server,[{error,closed}]} -> + io:format("Got server closed~n"), + ok + after 3000 -> + ct:fail({timeout,{closed,server}}) + end + after 3000 -> + ct:fail({timeout,{closed,[server,reader]}}) + end end. fill_sendq_srv(L, Master) -> diff --git a/lib/kernel/test/global_SUITE.erl b/lib/kernel/test/global_SUITE.erl index 0a7f73c344..0e7b7adc47 100644 --- a/lib/kernel/test/global_SUITE.erl +++ b/lib/kernel/test/global_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2016. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. @@ -3470,8 +3470,8 @@ start_procs(Parent, N1, N2, N3, Config) -> Pid6 = rpc:call(N3, ?MODULE, start_proc3, [test4]), assert_pid(Pid6), yes = global:register_name(test1, Pid3), - yes = global:register_name(test2, Pid4, {global, notify_all_name}), - yes = global:register_name(test3, Pid5, {global, random_notify_name}), + yes = global:register_name(test2, Pid4, fun global:notify_all_name/3), + yes = global:register_name(test3, Pid5, fun global:random_notify_name/3), Resolve = fun(Name, Pid1, Pid2) -> Parent ! {resolve_called, Name, node()}, {Min, Max} = minmax(Pid1, Pid2), @@ -3546,7 +3546,7 @@ start_proc_basic(Name) -> end. init_proc_basic(Parent, Name) -> - X = global:register_name(Name, self(), {?MODULE, fix_basic_name}), + X = global:register_name(Name, self(), fun ?MODULE:fix_basic_name/3), Parent ! {self(),X}, loop(). @@ -3791,15 +3791,6 @@ stop() -> test_server:stop_node(Node) end, nodes()). -dbg_logs(Name) -> dbg_logs(Name, ?NODES). - -dbg_logs(Name, Nodes) -> - lists:foreach(fun(N) -> - F = lists:concat([Name, ".log.", N, ".txt"]), - ok = sys:log_to_file({global_name_server, N}, F) - end, Nodes). - - %% Tests that locally loaded nodes do not loose contact with other nodes. global_lost_nodes(Config) when is_list(Config) -> Timeout = 60, diff --git a/lib/kernel/test/kernel_SUITE.erl b/lib/kernel/test/kernel_SUITE.erl index da56359294..7898988dbe 100644 --- a/lib/kernel/test/kernel_SUITE.erl +++ b/lib/kernel/test/kernel_SUITE.erl @@ -30,14 +30,14 @@ -export([init_per_testcase/2, end_per_testcase/2]). %% Test cases must be exported. --export([app_test/1, appup_test/1]). +-export([app_test/1, appup_test/1, refc/1]). suite() -> [{ct_hooks,[ts_install_cth]}, {timetrap,{minutes,2}}]. all() -> - [app_test, appup_test]. + [app_test, appup_test, refc]. groups() -> []. @@ -163,3 +163,68 @@ check_appup([Vsn|Vsns],Instrs,Expected) -> end; check_appup([],_,_) -> ok. + +%%% Check that refc module handles the counters as expected +refc(_Config) -> + Enable = fun(Enable) -> erlang:system_flag(scheduler_wall_time, Enable) end, + IsOn = fun() -> undefined /= erlang:statistics(scheduler_wall_time) end, + Tester = self(), + Loop = fun Loop() -> + receive + die -> normal; + {apply, Bool} -> + Res = Enable(Bool), + Tester ! {self(), Res}, + Loop() + end + end, + + %% Counter should be 0 + false = Enable(false), + + false = Enable(true), + true = Enable(true), + true = Enable(false), + true = Enable(false), + + %% Counter should be 0 + false = IsOn(), + + P1 = spawn_link(Loop), + P1 ! {apply, true}, + receive {P1, R1} -> false = R1 end, + + %% P1 has turned it on counter should be one + true = IsOn(), + true = Enable(true), + true = Enable(false), + true = IsOn(), + + P1 ! {apply, false}, + receive {P1, R2} -> true = R2 end, + false = IsOn(), + + P1 ! {apply, true}, + receive {P1, R3} -> false = R3 end, + true = IsOn(), + true = Enable(false), + + + P1 ! die, + timer:sleep(100), + false = IsOn(), + false = Enable(false), + + P2 = spawn_link(Loop), + P2 ! {apply, true}, + receive {P2, R4} -> false = R4 end, + true = IsOn(), + P2 ! {apply, true}, + receive {P2, R5} -> true = R5 end, + true = IsOn(), + + P2 ! die, + timer:sleep(100), + false = IsOn(), + + ok. diff --git a/lib/kernel/test/kernel_bench.spec b/lib/kernel/test/kernel_bench.spec index 8de60dae31..4de133f21b 100644 --- a/lib/kernel/test/kernel_bench.spec +++ b/lib/kernel/test/kernel_bench.spec @@ -1 +1,2 @@ {groups,"../kernel_test",zlib_SUITE,[bench]}. +{groups,"../kernel_test",file_SUITE,[bench]}. diff --git a/lib/kernel/test/prim_file_SUITE.erl b/lib/kernel/test/prim_file_SUITE.erl index 2f4330c217..ab62f4dc34 100644 --- a/lib/kernel/test/prim_file_SUITE.erl +++ b/lib/kernel/test/prim_file_SUITE.erl @@ -21,38 +21,23 @@ -export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, init_per_group/2,end_per_group/2, init_per_testcase/2, end_per_testcase/2, read_write_file/1, free_memory/0]). --export([cur_dir_0a/1, cur_dir_0b/1, - cur_dir_1a/1, cur_dir_1b/1, - make_del_dir_a/1, make_del_dir_b/1, - pos1/1, pos2/1]). --export([close/1, - delete_a/1, delete_b/1]). --export([ open1/1, modes/1]). --export([ - file_info_basic_file_a/1, file_info_basic_file_b/1, - file_info_basic_directory_a/1, file_info_basic_directory_b/1, - file_info_bad_a/1, file_info_bad_b/1, - file_info_times_a/1, file_info_times_b/1, - file_write_file_info_a/1, file_write_file_info_b/1, - file_read_file_info_opts/1, file_write_file_info_opts/1, - file_write_read_file_info_opts/1 - ]). --export([rename_a/1, rename_b/1, - access/1, truncate/1, datasync/1, sync/1, +-export([cur_dir_0/1, cur_dir_1/1, + make_del_dir/1, pos1/1, pos2/1]). +-export([close/1, delete/1]). +-export([open1/1, modes/1]). +-export([file_info_basic_file/1, file_info_basic_directory/1, file_info_bad/1, + file_info_times/1, file_write_file_info/1, + file_read_file_info_opts/1, file_write_file_info_opts/1, + file_write_read_file_info_opts/1]). +-export([rename/1, access/1, truncate/1, datasync/1, sync/1, read_write/1, pread_write/1, append/1, exclusive/1]). --export([ e_delete/1, e_rename/1, e_make_dir/1, e_del_dir/1]). +-export([e_delete/1, e_rename/1, e_make_dir/1, e_del_dir/1]). --export([ read_not_really_compressed/1, - read_compressed/1, write_compressed/1, - compress_errors/1]). - --export([ - make_link_a/1, make_link_b/1, - read_link_info_for_non_link/1, - symlinks_a/1, symlinks_b/1, - list_dir_limit/1, - list_dir_error/1, - list_dir/1]). +-export([make_link/1, read_link_info_for_non_link/1, + symlinks/1, + list_dir_limit/1, + list_dir_error/1, + list_dir/1]). -export([advise/1]). -export([large_write/1]). @@ -67,29 +52,16 @@ -define(PRIM_FILE, prim_file). -%% Calls ?PRIM_FILE:F with arguments A and an optional handle H -%% as first argument, unless the handle is [], i.e no handle. -%% This is a macro to give the compiler and thereby -%% the cross reference tool the possibility to interprete -%% the call, since M, F, A (or [H | A]) can all be known at -%% compile time. --define(PRIM_FILE_call(F, H, A), - case H of - [] -> apply(?PRIM_FILE, F, A); - _ -> apply(?PRIM_FILE, F, [H | A]) - end). - suite() -> []. all() -> [read_write_file, {group, dirs}, {group, files}, - delete_a, delete_b, rename_a, rename_b, {group, errors}, - {group, compression}, {group, links}, list_dir_limit, list_dir]. + delete, rename, {group, errors}, {group, links}, + list_dir_limit, list_dir]. groups() -> [{dirs, [], - [make_del_dir_a, make_del_dir_b, cur_dir_0a, cur_dir_0b, - cur_dir_1a, cur_dir_1b]}, + [make_del_dir, cur_dir_0, cur_dir_1]}, {files, [], [{group, open}, {group, pos}, {group, file_info}, truncate, sync, datasync, advise, large_write, allocate]}, @@ -98,22 +70,14 @@ groups() -> append, exclusive]}, {pos, [], [pos1, pos2]}, {file_info, [], - [file_info_basic_file_a, file_info_basic_file_b, - file_info_basic_directory_a, - file_info_basic_directory_b, file_info_bad_a, - file_info_bad_b, file_info_times_a, file_info_times_b, - file_write_file_info_a, file_write_file_info_b, - file_read_file_info_opts, file_write_file_info_opts, - file_write_read_file_info_opts + [file_info_basic_file,file_info_basic_directory, file_info_bad, + file_info_times, file_write_file_info, file_read_file_info_opts, + file_write_file_info_opts, file_write_read_file_info_opts ]}, {errors, [], [e_delete, e_rename, e_make_dir, e_del_dir]}, - {compression, [], - [read_compressed, read_not_really_compressed, - write_compressed, compress_errors]}, {links, [], - [make_link_a, make_link_b, read_link_info_for_non_link, - symlinks_a, symlinks_b, list_dir_error]}]. + [make_link, read_link_info_for_non_link, symlinks, list_dir_error]}]. init_per_testcase(large_write, Config) -> {ok, Started} = application:ensure_all_started(os_mon), @@ -246,39 +210,27 @@ read_write_file(Config) when is_list(Config) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -make_del_dir_a(Config) when is_list(Config) -> - make_del_dir(Config, [], "_a"). - -make_del_dir_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = make_del_dir(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - %% Just to make sure the state of the server makes a difference - {error, einval} = ?PRIM_FILE_call(get_cwd, Handle, []), - Result. - -make_del_dir(Config, Handle, Suffix) -> +make_del_dir(Config) when is_list(Config) -> RootDir = proplists:get_value(priv_dir,Config), NewDir = filename:join(RootDir, atom_to_list(?MODULE) - ++"_mk-dir"++Suffix), - ok = ?PRIM_FILE_call(make_dir, Handle, [NewDir]), - {error, eexist} = ?PRIM_FILE_call(make_dir, Handle, [NewDir]), - ok = ?PRIM_FILE_call(del_dir, Handle, [NewDir]), - {error, enoent} = ?PRIM_FILE_call(del_dir, Handle, [NewDir]), + ++"_mk-dir"), + ok = ?PRIM_FILE:make_dir(NewDir), + {error, eexist} = ?PRIM_FILE:make_dir(NewDir), + ok = ?PRIM_FILE:del_dir(NewDir), + {error, enoent} = ?PRIM_FILE:del_dir(NewDir), %% Make sure we are not in a directory directly under test_server %% as that would result in eacces errors when trying to delete '..', %% because there are processes having that directory as current. - ok = ?PRIM_FILE_call(make_dir, Handle, [NewDir]), - {ok, CurrentDir} = ?PRIM_FILE_call(get_cwd, Handle, []), + ok = ?PRIM_FILE:make_dir(NewDir), + {ok, CurrentDir} = ?PRIM_FILE:get_cwd(), case {os:type(), length(NewDir) >= 260 } of {{win32,_}, true} -> io:format("Skip set_cwd for windows path longer than 260 (MAX_PATH)\n", []), io:format("\nNewDir = ~p\n", [NewDir]); _ -> - ok = ?PRIM_FILE_call(set_cwd, Handle, [NewDir]) + ok = ?PRIM_FILE:set_cwd(NewDir) end, try %% Check that we get an error when trying to create... @@ -286,14 +238,14 @@ make_del_dir(Config, Handle, Suffix) -> NewDir2 = filename:join(RootDir, atom_to_list(?MODULE) ++"_mk-dir-noexist/foo"), - {error, enoent} = ?PRIM_FILE_call(make_dir, Handle, [NewDir2]), + {error, enoent} = ?PRIM_FILE:make_dir(NewDir2), %% a nameless directory - {error, enoent} = ?PRIM_FILE_call(make_dir, Handle, [""]), + {error, enoent} = ?PRIM_FILE:make_dir(""), %% a directory with illegal name - {error, badarg} = ?PRIM_FILE_call(make_dir, Handle, ['mk-dir']), + {error, badarg} = ?PRIM_FILE:make_dir('mk-dir'), %% a directory with illegal name, even if it's a (bad) list - {error, badarg} = ?PRIM_FILE_call(make_dir, Handle, [[1,2,3,{}]]), + {error, badarg} = ?PRIM_FILE:make_dir([1,2,3,{}]), %% Maybe this isn't an error, exactly, but worth mentioning anyway: %% ok = ?PRIM_FILE:make_dir([$f,$o,$o,0,$b,$a,$r])), @@ -306,125 +258,101 @@ make_del_dir(Config, Handle, Suffix) -> %% Try deleting some bad directories %% Deleting the parent directory to the current, sounds dangerous, huh? %% Don't worry ;-) the parent directory should never be empty, right? - case ?PRIM_FILE_call(del_dir, Handle, [".."]) of + case ?PRIM_FILE:del_dir("..") of {error, eexist} -> ok; {error, eacces} -> ok; %OpenBSD {error, einval} -> ok %FreeBSD end, - {error, enoent} = ?PRIM_FILE_call(del_dir, Handle, [""]), - {error, badarg} = ?PRIM_FILE_call(del_dir, Handle, [[3,2,1,{}]]) + {error, enoent} = ?PRIM_FILE:del_dir(""), + {error, badarg} = ?PRIM_FILE:del_dir([3,2,1,{}]) after - ok = ?PRIM_FILE_call(set_cwd, Handle, [CurrentDir]) + ok = ?PRIM_FILE:set_cwd(CurrentDir) end, ok. -cur_dir_0a(Config) when is_list(Config) -> - cur_dir_0(Config, []). - -cur_dir_0b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = cur_dir_0(Config, Handle), - ok = ?PRIM_FILE:stop(Handle), - Result. - -cur_dir_0(Config, Handle) -> +cur_dir_0(Config) when is_list(Config) -> %% Find out the current dir, and cd to it ;-) - {ok,BaseDir} = ?PRIM_FILE_call(get_cwd, Handle, []), + {ok,BaseDir} = ?PRIM_FILE:get_cwd(), Dir1 = BaseDir ++ "", %% Check that it's a string - ok = ?PRIM_FILE_call(set_cwd, Handle, [Dir1]), - DirName = atom_to_list(?MODULE) ++ - case Handle of - [] -> - "_curdir"; - _ -> - "_curdir_h" - end, + ok = ?PRIM_FILE:set_cwd(Dir1), + DirName = atom_to_list(?MODULE) ++ "_curdir", %% Make a new dir, and cd to that RootDir = proplists:get_value(priv_dir,Config), NewDir = filename:join(RootDir, DirName), - ok = ?PRIM_FILE_call(make_dir, Handle, [NewDir]), + ok = ?PRIM_FILE:make_dir(NewDir), case {os:type(), length(NewDir) >= 260} of {{win32,_}, true} -> io:format("Skip set_cwd for windows path longer than 260 (MAX_PATH):\n"), io:format("\nNewDir = ~p\n", [NewDir]); _ -> io:format("cd to ~s",[NewDir]), - ok = ?PRIM_FILE_call(set_cwd, Handle, [NewDir]), + ok = ?PRIM_FILE:set_cwd(NewDir), %% Create a file in the new current directory, and check that it %% really is created there UncommonName = "uncommon.fil", {ok,Fd} = ?PRIM_FILE:open(UncommonName, [read, write]), ok = ?PRIM_FILE:close(Fd), - {ok,NewDirFiles} = ?PRIM_FILE_call(list_dir, Handle, ["."]), + {ok,NewDirFiles} = ?PRIM_FILE:list_dir("."), true = lists:member(UncommonName,NewDirFiles), %% Delete the directory and return to the old current directory %% and check that the created file isn't there (too!) expect({error, einval}, {error, eacces}, {error, eexist}, - ?PRIM_FILE_call(del_dir, Handle, [NewDir])), - ?PRIM_FILE_call(delete, Handle, [UncommonName]), - {ok,[]} = ?PRIM_FILE_call(list_dir, Handle, ["."]), - ok = ?PRIM_FILE_call(set_cwd, Handle, [Dir1]), + ?PRIM_FILE:del_dir(NewDir)), + ?PRIM_FILE:delete(UncommonName), + {ok,[]} = ?PRIM_FILE:list_dir("."), + ok = ?PRIM_FILE:set_cwd(Dir1), io:format("cd back to ~s",[Dir1]), - ok = ?PRIM_FILE_call(del_dir, Handle, [NewDir]), - {error, enoent} = ?PRIM_FILE_call(set_cwd, Handle, [NewDir]), - ok = ?PRIM_FILE_call(set_cwd, Handle, [Dir1]), + ok = ?PRIM_FILE:del_dir(NewDir), + {error, enoent} = ?PRIM_FILE:set_cwd(NewDir), + ok = ?PRIM_FILE:set_cwd(Dir1), io:format("cd back to ~s",[Dir1]), - {ok,OldDirFiles} = ?PRIM_FILE_call(list_dir, Handle, ["."]), + {ok,OldDirFiles} = ?PRIM_FILE:list_dir("."), false = lists:member(UncommonName,OldDirFiles) end, %% Try doing some bad things {error, badarg} = - ?PRIM_FILE_call(set_cwd, Handle, [{foo,bar}]), + ?PRIM_FILE:set_cwd({foo,bar}), {error, enoent} = - ?PRIM_FILE_call(set_cwd, Handle, [""]), + ?PRIM_FILE:set_cwd(""), {error, enoent} = - ?PRIM_FILE_call(set_cwd, Handle, [".......a......"]), + ?PRIM_FILE:set_cwd(".......a......"), {ok,BaseDir} = - ?PRIM_FILE_call(get_cwd, Handle, []), %% Still there? + ?PRIM_FILE:get_cwd(), %% Still there? %% On Windows, there should only be slashes, no backslashes, %% in the return value of get_cwd(). %% (The test is harmless on Unix, because filenames usually %% don't contain backslashes.) - {ok, BaseDir} = ?PRIM_FILE_call(get_cwd, Handle, []), + {ok, BaseDir} = ?PRIM_FILE:get_cwd(), false = lists:member($\\, BaseDir), ok. %% Tests ?PRIM_FILE:get_cwd/1. -cur_dir_1a(Config) when is_list(Config) -> - cur_dir_1(Config, []). - -cur_dir_1b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = cur_dir_1(Config, Handle), - ok = ?PRIM_FILE:stop(Handle), - Result. - -cur_dir_1(Config, Handle) -> +cur_dir_1(Config) when is_list(Config) -> case os:type() of {win32, _} -> - win_cur_dir_1(Config, Handle); + win_cur_dir_1(Config); _ -> {error, enotsup} = - ?PRIM_FILE_call(get_cwd, Handle, ["d:"]) + ?PRIM_FILE:get_cwd("d:") end, ok. -win_cur_dir_1(_Config, Handle) -> - {ok, BaseDir} = ?PRIM_FILE_call(get_cwd, Handle, []), +win_cur_dir_1(_Config) -> + {ok, BaseDir} = ?PRIM_FILE:get_cwd(), %% Get the drive letter from the current directory, %% and try to get current directory for that drive. [Drive, $:|_] = BaseDir, - {ok, BaseDir} = ?PRIM_FILE_call(get_cwd, Handle, [[Drive, $:]]), + {ok, BaseDir} = ?PRIM_FILE:get_cwd([Drive, $:]), io:format("BaseDir = ~s\n", [BaseDir]), %% Unfortunately, there is no way to move away from the @@ -446,12 +374,12 @@ open1(Config) when is_list(Config) -> Name = filename:join(NewDir, "foo1.fil"), {ok,Fd1} = ?PRIM_FILE:open(Name, [read, write]), {ok,Fd2} = ?PRIM_FILE:open(Name, [read]), - Str = "{a,tuple}.\n", - Length = length(Str), - ?PRIM_FILE:write(Fd1,Str), + Bin = list_to_binary("{a,tuple}.\n"), + Length = byte_size(Bin), + ?PRIM_FILE:write(Fd1,Bin), {ok,0} = ?PRIM_FILE:position(Fd1,bof), - {ok, Str} = ?PRIM_FILE:read(Fd1,Length), - {ok, Str} = ?PRIM_FILE:read(Fd2,Length), + {ok, Bin} = ?PRIM_FILE:read(Fd1,Length), + {ok, Bin} = ?PRIM_FILE:read(Fd2,Length), ok = ?PRIM_FILE:close(Fd2), {ok,0} = ?PRIM_FILE:position(Fd1,bof), ok = ?PRIM_FILE:truncate(Fd1), @@ -471,13 +399,13 @@ modes(Config) when is_list(Config) -> ++"_open_modes"), ok = ?PRIM_FILE:make_dir(NewDir), Name1 = filename:join(NewDir, "foo1.fil"), - Marker = "hello, world", - Length = length(Marker), + Marker = <<"hello, world">>, + Length = byte_size(Marker), %% write {ok, Fd1} = ?PRIM_FILE:open(Name1, [write]), ok = ?PRIM_FILE:write(Fd1, Marker), - ok = ?PRIM_FILE:write(Fd1, ".\n"), + ok = ?PRIM_FILE:write(Fd1, <<".\n">>), ok = ?PRIM_FILE:close(Fd1), %% read @@ -496,12 +424,6 @@ modes(Config) when is_list(Config) -> {ok, Marker} = ?PRIM_FILE:read(Fd4, Length), ok = ?PRIM_FILE:close(Fd4), - %% read and binary - BinaryMarker = list_to_binary(Marker), - {ok, Fd5} = ?PRIM_FILE:open(Name1, [read, binary]), - {ok, BinaryMarker} = ?PRIM_FILE:read(Fd5, Length), - ok = ?PRIM_FILE:close(Fd5), - ok. close(Config) when is_list(Config) -> @@ -528,9 +450,9 @@ access(Config) when is_list(Config) -> Name = filename:join(RootDir, atom_to_list(?MODULE) ++"_access.fil"), - Str = "ABCDEFGH", + Bin = <<"ABCDEFGH">>, {ok,Fd1} = ?PRIM_FILE:open(Name, [write]), - ?PRIM_FILE:write(Fd1,Str), + ?PRIM_FILE:write(Fd1,Bin), ok = ?PRIM_FILE:close(Fd1), %% Check that we can't write when in read only mode {ok,Fd2} = ?PRIM_FILE:open(Name, [read]), @@ -542,7 +464,7 @@ access(Config) when is_list(Config) -> end, ok = ?PRIM_FILE:close(Fd2), {ok, Fd3} = ?PRIM_FILE:open(Name, [read]), - {ok, Str} = ?PRIM_FILE:read(Fd3,length(Str)), + {ok, Bin} = ?PRIM_FILE:read(Fd3,byte_size(Bin)), ok = ?PRIM_FILE:close(Fd3), ok. @@ -564,7 +486,7 @@ read_write(Config) when is_list(Config) -> ok. read_write_test(File) -> - Marker = "hello, world", + Marker = <<"hello, world">>, ok = ?PRIM_FILE:write(File, Marker), {ok, 0} = ?PRIM_FILE:position(File, 0), {ok, Marker} = ?PRIM_FILE:read(File, 100), @@ -590,15 +512,15 @@ pread_write(Config) when is_list(Config) -> ok. pread_write_test(File) -> - Marker = "hello, world", - Len = length(Marker), + Marker = <<"hello, world">>, + Len = byte_size(Marker), ok = ?PRIM_FILE:write(File, Marker), {ok, Marker} = ?PRIM_FILE:pread(File, 0, 100), eof = ?PRIM_FILE:pread(File, 100, 1), ok = ?PRIM_FILE:pwrite(File, Len, Marker), {ok, Marker} = ?PRIM_FILE:pread(File, Len, 100), eof = ?PRIM_FILE:pread(File, 100, 1), - MM = Marker ++ Marker, + MM = <<Marker/binary,Marker/binary>>, {ok, MM} = ?PRIM_FILE:pread(File, 0, 100), ok = ?PRIM_FILE:close(File), ok. @@ -655,24 +577,24 @@ pos1(Config) when is_list(Config) -> atom_to_list(?MODULE) ++"_pos1.fil"), {ok, Fd1} = ?PRIM_FILE:open(Name, [write]), - ?PRIM_FILE:write(Fd1,"ABCDEFGH"), + ?PRIM_FILE:write(Fd1,<<"ABCDEFGH">>), ok = ?PRIM_FILE:close(Fd1), {ok, Fd2} = ?PRIM_FILE:open(Name, [read]), %% Start pos is first char io:format("Relative positions"), - {ok, "A"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"A">>} = ?PRIM_FILE:read(Fd2,1), {ok, 2} = ?PRIM_FILE:position(Fd2,{cur,1}), - {ok, "C"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"C">>} = ?PRIM_FILE:read(Fd2,1), {ok, 0} = ?PRIM_FILE:position(Fd2,{cur,-3}), - {ok, "A"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"A">>} = ?PRIM_FILE:read(Fd2,1), %% Backwards from first char should be an error {ok,0} = ?PRIM_FILE:position(Fd2,{cur,-1}), {error, einval} = ?PRIM_FILE:position(Fd2,{cur,-1}), %% Reset position and move again {ok, 0} = ?PRIM_FILE:position(Fd2,0), {ok, 2} = ?PRIM_FILE:position(Fd2,{cur,2}), - {ok, "C"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"C">>} = ?PRIM_FILE:read(Fd2,1), %% Go a lot forwards {ok, 13} = ?PRIM_FILE:position(Fd2,{cur,10}), eof = ?PRIM_FILE:read(Fd2,1), @@ -684,27 +606,27 @@ pos1(Config) when is_list(Config) -> {ok, 8} = ?PRIM_FILE:position(Fd2,cur), eof = ?PRIM_FILE:read(Fd2,1), {ok, 7} = ?PRIM_FILE:position(Fd2,7), - {ok, "H"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"H">>} = ?PRIM_FILE:read(Fd2,1), {ok, 0} = ?PRIM_FILE:position(Fd2,0), - {ok, "A"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"A">>} = ?PRIM_FILE:read(Fd2,1), {ok, 3} = ?PRIM_FILE:position(Fd2,3), - {ok, "D"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"D">>} = ?PRIM_FILE:read(Fd2,1), {ok, 12} = ?PRIM_FILE:position(Fd2,12), eof = ?PRIM_FILE:read(Fd2,1), {ok, 3} = ?PRIM_FILE:position(Fd2,3), - {ok, "D"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"D">>} = ?PRIM_FILE:read(Fd2,1), %% Try the {bof,X} notation {ok, 3} = ?PRIM_FILE:position(Fd2,{bof,3}), - {ok, "D"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"D">>} = ?PRIM_FILE:read(Fd2,1), %% Try eof positions io:format("EOF positions"), {ok, 8} = ?PRIM_FILE:position(Fd2,{eof,0}), eof = ?PRIM_FILE:read(Fd2,1), {ok, 7} = ?PRIM_FILE:position(Fd2,{eof,-1}), - {ok, "H"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"H">>} = ?PRIM_FILE:read(Fd2,1), {ok, 0} = ?PRIM_FILE:position(Fd2,{eof,-8}), - {ok, "A"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"A">>} = ?PRIM_FILE:read(Fd2,1), {error, einval} = ?PRIM_FILE:position(Fd2,{eof,-9}), ok. @@ -714,7 +636,7 @@ pos2(Config) when is_list(Config) -> atom_to_list(?MODULE) ++"_pos2.fil"), {ok,Fd1} = ?PRIM_FILE:open(Name, [write]), - ?PRIM_FILE:write(Fd1,"ABCDEFGH"), + ?PRIM_FILE:write(Fd1,<<"ABCDEFGH">>), ok = ?PRIM_FILE:close(Fd1), {ok, Fd2} = ?PRIM_FILE:open(Name, [read]), {error, einval} = ?PRIM_FILE:position(Fd2,-1), @@ -722,35 +644,25 @@ pos2(Config) when is_list(Config) -> %% Make sure that we still can search after an error. {ok, 0} = ?PRIM_FILE:position(Fd2, 0), {ok, 3} = ?PRIM_FILE:position(Fd2, {bof,3}), - {ok, "D"} = ?PRIM_FILE:read(Fd2,1), + {ok, <<"D">>} = ?PRIM_FILE:read(Fd2,1), io:format("DONE"), ok. - -file_info_basic_file_a(Config) when is_list(Config) -> - file_info_basic_file(Config, [], "_a"). - -file_info_basic_file_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = file_info_basic_file(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - Result. - -file_info_basic_file(Config, Handle, Suffix) -> +file_info_basic_file(Config) when is_list(Config) -> RootDir = proplists:get_value(priv_dir, Config), %% Create a short file. Name = filename:join(RootDir, atom_to_list(?MODULE) - ++"_basic_test"++Suffix++".fil"), + ++"_basic_test"".fil"), {ok,Fd1} = ?PRIM_FILE:open(Name, [write]), ?PRIM_FILE:write(Fd1, "foo bar"), ok = ?PRIM_FILE:close(Fd1), %% Test that the file has the expected attributes. %% The times are tricky, so we will save them to a separate test case. - {ok, FileInfo} = ?PRIM_FILE_call(read_file_info, Handle, [Name]), + {ok, FileInfo} = ?PRIM_FILE:read_file_info(Name), #file_info{size = Size, type = Type, access = Access, atime = AccessTime, mtime = ModifyTime} = FileInfo, @@ -768,39 +680,30 @@ file_info_basic_file(Config, Handle, Suffix) -> ok. -file_info_basic_directory_a(Config) when is_list(Config) -> - file_info_basic_directory(Config, []). - -file_info_basic_directory_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = file_info_basic_directory(Config, Handle), - ok = ?PRIM_FILE:stop(Handle), - Result. - -file_info_basic_directory(Config, Handle) -> +file_info_basic_directory(Config) when is_list(Config) -> %% Note: filename:join/1 removes any trailing slash, %% which is essential for ?PRIM_FILE:read_file_info/1 to work on %% platforms such as Windows95. RootDir = filename:join([proplists:get_value(priv_dir, Config)]), %% Test that the RootDir directory has the expected attributes. - test_directory(RootDir, read_write, Handle), + test_directory(RootDir, read_write), %% Note that on Windows file systems, "/" or "c:/" are *NOT* directories. %% Therefore, test that ?PRIM_FILE:read_file_info/1 behaves %% as if they were directories. case os:type() of {win32, _} -> - test_directory("/", read_write, Handle), - test_directory("c:/", read_write, Handle), - test_directory("c:\\", read_write, Handle); + test_directory("/", read_write), + test_directory("c:/", read_write), + test_directory("c:\\", read_write); _ -> - test_directory("/", read, Handle) + test_directory("/", read) end, ok. -test_directory(Name, ExpectedAccess, Handle) -> - {ok, FileInfo} = ?PRIM_FILE_call(read_file_info, Handle, [Name]), +test_directory(Name, ExpectedAccess) -> + {ok, FileInfo} = ?PRIM_FILE:read_file_info(Name), #file_info{size = Size, type = Type, access = Access, atime = AccessTime, mtime = ModifyTime} = FileInfo, @@ -824,45 +727,24 @@ all_integers([]) -> %% Try something nonexistent. -file_info_bad_a(Config) when is_list(Config) -> - file_info_bad(Config, []). - -file_info_bad_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = file_info_bad(Config, Handle), - ok = ?PRIM_FILE:stop(Handle), - Result. - -file_info_bad(Config, Handle) -> +file_info_bad(Config) when is_list(Config) -> RootDir = filename:join([proplists:get_value(priv_dir, Config)]), - {error, enoent} = - ?PRIM_FILE_call( - read_file_info, Handle, - [filename:join(RootDir, - atom_to_list(?MODULE)++"_nonexistent")]), + NonExistent = filename:join(RootDir, atom_to_list(?MODULE)++"_nonexistent"), + {error, enoent} = ?PRIM_FILE:read_file_info(NonExistent), ok. %% Test that the file times behave as they should. -file_info_times_a(Config) when is_list(Config) -> - file_info_times(Config, [], "_a"). - -file_info_times_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = file_info_times(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - Result. - -file_info_times(Config, Handle, Suffix) -> +file_info_times(Config) when is_list(Config) -> %% We have to try this twice, since if the test runs across the change %% of a month the time diff calculations will fail. But it won't happen %% if you run it twice in succession. test_server:m_out_of_n( 1,2, - fun() -> file_info_int(Config, Handle, Suffix) end), + fun() -> file_info_int(Config) end), ok. -file_info_int(Config, Handle, Suffix) -> +file_info_int(Config) -> %% Note: filename:join/1 removes any trailing slash, %% which is essential for ?PRIM_FILE:read_file_info/1 to work on %% platforms such as Windows95. @@ -872,14 +754,14 @@ file_info_int(Config, Handle, Suffix) -> Name = filename:join(RootDir, atom_to_list(?MODULE) - ++"_file_info"++Suffix++".fil"), + ++"_file_info.fil"), {ok,Fd1} = ?PRIM_FILE:open(Name, [write]), ?PRIM_FILE:write(Fd1,"foo"), %% check that the file got a modify date max a few seconds away from now {ok, #file_info{type = regular, atime = AccTime1, mtime = ModTime1}} = - ?PRIM_FILE_call(read_file_info, Handle, [Name]), + ?PRIM_FILE:read_file_info(Name), Now = erlang:localtime(), io:format("Now ~p",[Now]), io:format("Open file Acc ~p Mod ~p",[AccTime1,ModTime1]), @@ -897,7 +779,7 @@ file_info_int(Config, Handle, Suffix) -> ok = ?PRIM_FILE:close(Fd1), {ok, #file_info{size = Size, type = regular, access = Access, atime = AccTime2, mtime = ModTime2}} = - ?PRIM_FILE_call(read_file_info, Handle, [Name]), + ?PRIM_FILE:read_file_info(Name), io:format("Closed file Acc ~p Mod ~p",[AccTime2,ModTime2]), true = time_dist(ModTime1, ModTime2) >= 0, @@ -909,7 +791,7 @@ file_info_int(Config, Handle, Suffix) -> {ok, #file_info{size = DSize, type = directory, access = DAccess, atime = AccTime3, mtime = ModTime3}} = - ?PRIM_FILE_call(read_file_info, Handle, [RootDir]), + ?PRIM_FILE:read_file_info(RootDir), %% this dir was modified only a few secs ago io:format("Dir Acc ~p; Mod ~p; Now ~p", [AccTime3, ModTime3, Now]), @@ -936,16 +818,7 @@ filter_atime(Atime, Config) -> %% Test the write_file_info/2 function. -file_write_file_info_a(Config) when is_list(Config) -> - file_write_file_info(Config, [], "_a"). - -file_write_file_info_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = file_write_file_info(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - Result. - -file_write_file_info(Config, Handle, Suffix) -> +file_write_file_info(Config) when is_list(Config) -> RootDir = get_good_directory(Config), io:format("RootDir = ~p", [RootDir]), @@ -955,16 +828,16 @@ file_write_file_info(Config, Handle, Suffix) -> Name = filename:join(RootDir, atom_to_list(?MODULE) - ++"_write_file_info_ro"++Suffix), + ++"_write_file_info_ro"), ok = ?PRIM_FILE:write_file(Name, "hello"), Time = {{1997, 01, 02}, {12, 35, 42}}, Info = #file_info{mode=8#400, atime=Time, mtime=Time, ctime=Time}, - ok = ?PRIM_FILE_call(write_file_info, Handle, [Name, Info]), + ok = ?PRIM_FILE:write_file_info(Name, Info), %% Read back the times. {ok, ActualInfo} = - ?PRIM_FILE_call(read_file_info, Handle, [Name]), + ?PRIM_FILE:read_file_info(Name), #file_info{mode=_Mode, atime=ActAtime, mtime=Time, ctime=ActCtime} = ActualInfo, FilteredAtime = filter_atime(Time, Config), @@ -980,14 +853,11 @@ file_write_file_info(Config, Handle, Suffix) -> {error, eacces} = ?PRIM_FILE:write_file(Name, "hello again"), %% Make the file writable again. - - ?PRIM_FILE_call(write_file_info, Handle, - [Name, #file_info{mode=8#600}]), + ?PRIM_FILE:write_file_info(Name, #file_info{mode=8#600}), ok = ?PRIM_FILE:write_file(Name, "hello again"), %% And unwritable. - ?PRIM_FILE_call(write_file_info, Handle, - [Name, #file_info{mode=8#400}]), + ?PRIM_FILE:write_file_info(Name, #file_info{mode=8#400}), {error, eacces} = ?PRIM_FILE:write_file(Name, "hello again"), %% Write the times again. @@ -995,9 +865,9 @@ file_write_file_info(Config, Handle, Suffix) -> NewTime = {{1997, 02, 15}, {13, 18, 20}}, NewInfo = #file_info{atime=NewTime, mtime=NewTime, ctime=NewTime}, - ok = ?PRIM_FILE_call(write_file_info, Handle, [Name, NewInfo]), + ok = ?PRIM_FILE:write_file_info(Name, NewInfo), {ok, ActualInfo2} = - ?PRIM_FILE_call(read_file_info, Handle, [Name]), + ?PRIM_FILE:read_file_info(Name), #file_info{atime=NewActAtime, mtime=NewTime, ctime=NewActCtime} = ActualInfo2, NewFilteredAtime = filter_atime(NewTime, Config), @@ -1012,14 +882,12 @@ file_write_file_info(Config, Handle, Suffix) -> %% Make the file writeable again, so that we can remove the %% test suites ... :-) - ?PRIM_FILE_call(write_file_info, Handle, - [Name, #file_info{mode=8#600}]), + ?PRIM_FILE:write_file_info(Name, #file_info{mode=8#600}), ok. %% Test the write_file_info/3 function. file_write_file_info_opts(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), RootDir = get_good_directory(Config), io:format("RootDir = ~p", [RootDir]), @@ -1028,7 +896,7 @@ file_write_file_info_opts(Config) when is_list(Config) -> lists:foreach(fun ({FI, Opts}) -> - ok = ?PRIM_FILE_call(write_file_info, Handle, [Name, FI, Opts]) + ok = ?PRIM_FILE:write_file_info(Name, FI, Opts) end, [ {#file_info{ mode=8#600, atime = Time, mtime = Time, ctime = Time}, Opts} || Opts <- [[{time, posix}]], @@ -1038,7 +906,7 @@ file_write_file_info_opts(Config) when is_list(Config) -> %% REM: determine date range dependent on time_t = Uint32 | Sint32 | Sint64 | Uint64 %% Determine time_t on os:type()? lists:foreach(fun ({FI, Opts}) -> - ok = ?PRIM_FILE_call(write_file_info, Handle, [Name, FI, Opts]) + ok = ?PRIM_FILE:write_file_info(Name, FI, Opts) end, [ {#file_info{ mode=8#400, atime = Time, mtime = Time, ctime = Time}, Opts} || Opts <- [[{time, universal}],[{time, local}]], Time <- [ @@ -1050,11 +918,9 @@ file_write_file_info_opts(Config) when is_list(Config) -> {{2037,2,3},{23,59,59}}, erlang:localtime() ]]), - ok = ?PRIM_FILE:stop(Handle), ok. file_read_file_info_opts(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), RootDir = get_good_directory(Config), io:format("RootDir = ~p", [RootDir]), @@ -1063,41 +929,38 @@ file_read_file_info_opts(Config) when is_list(Config) -> lists:foreach(fun (Opts) -> - {ok,_} = ?PRIM_FILE_call(read_file_info, Handle, [Name, Opts]) + {ok,_} = ?PRIM_FILE:read_file_info(Name, Opts) end, [[{time, Type}] || Type <- [local, universal, posix]]), - ok = ?PRIM_FILE:stop(Handle), ok. %% Test the write and read back *_file_info/3 functions. file_write_read_file_info_opts(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), RootDir = get_good_directory(Config), io:format("RootDir = ~p", [RootDir]), Name = filename:join(RootDir, atom_to_list(?MODULE) ++"_read_write_file_info_opts"), ok = ?PRIM_FILE:write_file(Name, "hello_opts2"), - ok = file_write_read_file_info_opts(Handle, Name, {{1989, 04, 28}, {19,30,22}}, [{time, local}]), - ok = file_write_read_file_info_opts(Handle, Name, {{1989, 04, 28}, {19,30,22}}, [{time, universal}]), + ok = file_write_read_file_info_opts(Name, {{1989, 04, 28}, {19,30,22}}, [{time, local}]), + ok = file_write_read_file_info_opts(Name, {{1989, 04, 28}, {19,30,22}}, [{time, universal}]), %% will not work on platforms with unsigned time_t - %ok = file_write_read_file_info_opts(Handle, Name, {{1930, 04, 28}, {19,30,22}}, [{time, local}]), - %ok = file_write_read_file_info_opts(Handle, Name, {{1930, 04, 28}, {19,30,22}}, [{time, universal}]), - ok = file_write_read_file_info_opts(Handle, Name, 1, [{time, posix}]), + %ok = file_write_read_file_info_opts(Name, {{1930, 04, 28}, {19,30,22}}, [{time, local}]), + %ok = file_write_read_file_info_opts(Name, {{1930, 04, 28}, {19,30,22}}, [{time, universal}]), + ok = file_write_read_file_info_opts(Name, 1, [{time, posix}]), %% will not work on platforms with unsigned time_t - %ok = file_write_read_file_info_opts(Handle, Name, -1, [{time, posix}]), - %ok = file_write_read_file_info_opts(Handle, Name, -300000, [{time, posix}]), - ok = file_write_read_file_info_opts(Handle, Name, 300000, [{time, posix}]), - ok = file_write_read_file_info_opts(Handle, Name, 0, [{time, posix}]), + %ok = file_write_read_file_info_opts(Name, -1, [{time, posix}]), + %ok = file_write_read_file_info_opts(Name, -300000, [{time, posix}]), + ok = file_write_read_file_info_opts(Name, 300000, [{time, posix}]), + ok = file_write_read_file_info_opts(Name, 0, [{time, posix}]), - ok = ?PRIM_FILE:stop(Handle), ok. -file_write_read_file_info_opts(Handle, Name, Mtime, Opts) -> - {ok, FI} = ?PRIM_FILE_call(read_file_info, Handle, [Name, Opts]), +file_write_read_file_info_opts(Name, Mtime, Opts) -> + {ok, FI} = ?PRIM_FILE:read_file_info(Name, Opts), FI2 = FI#file_info{ mtime = Mtime }, - ok = ?PRIM_FILE_call(write_file_info, Handle, [Name, FI2, Opts]), - {ok, FI3} = ?PRIM_FILE_call(read_file_info, Handle, [Name, Opts]), + ok = ?PRIM_FILE:write_file_info(Name, FI2, Opts), + {ok, FI3} = ?PRIM_FILE:read_file_info(Name, Opts), io:format("Expecting mtime = ~p, got ~p~n", [FI2#file_info.mtime, FI3#file_info.mtime]), FI2 = FI3, ok. @@ -1175,8 +1038,8 @@ advise(Config) when is_list(Config) -> atom_to_list(?MODULE) ++"_advise.fil"), - Line1 = "Hello\n", - Line2 = "World!\n", + Line1 = <<"Hello\n">>, + Line2 = <<"World!\n">>, {ok, Fd} = ?PRIM_FILE:open(Advise, [write]), ok = ?PRIM_FILE:advise(Fd, 0, 0, normal), @@ -1226,7 +1089,7 @@ advise(Config) when is_list(Config) -> {ok, Fd9} = ?PRIM_FILE:open(Advise, [read]), Offset = 0, %% same as a 0 length in some implementations - Length = length(Line1) + length(Line2), + Length = byte_size(Line1) + byte_size(Line2), ok = ?PRIM_FILE:advise(Fd9, Offset, Length, sequential), {ok, Line1} = ?PRIM_FILE:read_line(Fd9), {ok, Line2} = ?PRIM_FILE:read_line(Fd9), @@ -1250,23 +1113,18 @@ do_large_write(Name) -> Chunk = <<0:ChunkSize/unit:8>>, Data = zip_data(lists:duplicate(Chunks, Chunk), Interleave), Size = Chunks * ChunkSize + Chunks, % 4 G + 32 - Wordsize = erlang:system_info(wordsize), - case prim_file:write_file(Name, Data) of - ok when Wordsize =:= 8 -> - {ok,#file_info{size=Size}} = file:read_file_info(Name), - {ok,Fd} = prim_file:open(Name, [read]), - check_large_write(Fd, ChunkSize, 0, Interleave); - {error,einval} when Wordsize =:= 4 -> - ok - end. + ok = ?PRIM_FILE:write_file(Name, Data), + {ok,#file_info{size=Size}} = file:read_file_info(Name), + {ok,Fd} = ?PRIM_FILE:open(Name, [read]), + check_large_write(Fd, ChunkSize, 0, Interleave). check_large_write(Fd, ChunkSize, Pos, [X|Interleave]) -> Pos1 = Pos + ChunkSize, - {ok,Pos1} = prim_file:position(Fd, {cur,ChunkSize}), - {ok,[X]} = prim_file:read(Fd, 1), + {ok,Pos1} = ?PRIM_FILE:position(Fd, {cur,ChunkSize}), + {ok,<<X>>} = ?PRIM_FILE:read(Fd, 1), check_large_write(Fd, ChunkSize, Pos1+1, Interleave); check_large_write(Fd, _, _, []) -> - eof = prim_file:read(Fd, 1), + eof = ?PRIM_FILE:read(Fd, 1), ok. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -1338,71 +1196,53 @@ allocate_and_assert(Fd, Offset, Length) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -delete_a(Config) when is_list(Config) -> - delete(Config, [], "_a"). - -delete_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = delete(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - Result. - -delete(Config, Handle, Suffix) -> +delete(Config) when is_list(Config) -> RootDir = proplists:get_value(priv_dir,Config), Name = filename:join(RootDir, atom_to_list(?MODULE) - ++"_delete"++Suffix++".fil"), + ++"_delete.fil"), {ok, Fd1} = ?PRIM_FILE:open(Name, [write]), ?PRIM_FILE:write(Fd1,"ok.\n"), ok = ?PRIM_FILE:close(Fd1), %% Check that the file is readable {ok, Fd2} = ?PRIM_FILE:open(Name, [read]), ok = ?PRIM_FILE:close(Fd2), - ok = ?PRIM_FILE_call(delete, Handle, [Name]), + ok = ?PRIM_FILE:delete(Name), %% Check that the file is not readable anymore {error, _} = ?PRIM_FILE:open(Name, [read]), %% Try deleting a nonexistent file - {error, enoent} = ?PRIM_FILE_call(delete, Handle, [Name]), + {error, enoent} = ?PRIM_FILE:delete(Name), ok. -rename_a(Config) when is_list(Config) -> - rename(Config, [], "_a"). - -rename_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = rename(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - Result. - -rename(Config, Handle, Suffix) -> +rename(Config) when is_list(Config) -> RootDir = proplists:get_value(priv_dir,Config), - FileName1 = atom_to_list(?MODULE)++"_rename"++Suffix++".fil", - FileName2 = atom_to_list(?MODULE)++"_rename"++Suffix++".ful", + FileName1 = atom_to_list(?MODULE)++"_rename.fil", + FileName2 = atom_to_list(?MODULE)++"_rename.ful", Name1 = filename:join(RootDir, FileName1), Name2 = filename:join(RootDir, FileName2), {ok,Fd1} = ?PRIM_FILE:open(Name1, [write]), ok = ?PRIM_FILE:close(Fd1), %% Rename, and check that it really changed name - ok = ?PRIM_FILE_call(rename, Handle, [Name1, Name2]), + ok = ?PRIM_FILE:rename(Name1, Name2), {error, _} = ?PRIM_FILE:open(Name1, [read]), {ok, Fd2} = ?PRIM_FILE:open(Name2, [read]), ok = ?PRIM_FILE:close(Fd2), %% Try renaming something to itself - ok = ?PRIM_FILE_call(rename, Handle, [Name2, Name2]), + ok = ?PRIM_FILE:rename(Name2, Name2), %% Try renaming something that doesn't exist {error, enoent} = - ?PRIM_FILE_call(rename, Handle, [Name1, Name2]), + ?PRIM_FILE:rename(Name1, Name2), %% Try renaming to something else than a string {error, badarg} = - ?PRIM_FILE_call(rename, Handle, [Name1, foobar]), + ?PRIM_FILE:rename(Name1, foobar), %% Move between directories DirName1 = filename:join(RootDir, atom_to_list(?MODULE) - ++"_rename_dir"++Suffix), + ++"_rename_dir"), DirName2 = filename:join(RootDir, atom_to_list(?MODULE) - ++"_second_rename_dir"++Suffix), + ++"_second_rename_dir"), Name1foo = filename:join(DirName1, "foo.fil"), Name2foo = filename:join(DirName2, "foo.fil"), Name2bar = filename:join(DirName2, "bar.dir"), @@ -1410,21 +1250,21 @@ rename(Config, Handle, Suffix) -> %% The name has to include the full file name, path is not enough expect( {error, eexist}, {error, eisdir}, - ?PRIM_FILE_call(rename, Handle, [Name2, DirName1])), + ?PRIM_FILE:rename(Name2, DirName1)), ok = - ?PRIM_FILE_call(rename, Handle, [Name2, Name1foo]), + ?PRIM_FILE:rename(Name2, Name1foo), %% Now rename the directory - ok = ?PRIM_FILE_call(rename, Handle, [DirName1, DirName2]), + ok = ?PRIM_FILE:rename(DirName1, DirName2), %% And check that the file is there now {ok,Fd3} = ?PRIM_FILE:open(Name2foo, [read]), ok = ?PRIM_FILE:close(Fd3), %% Try some dirty things now: move the directory into itself {error, Msg1} = - ?PRIM_FILE_call(rename, Handle, [DirName2, Name2bar]), + ?PRIM_FILE:rename(DirName2, Name2bar), io:format("Errmsg1: ~p",[Msg1]), %% move dir into a file in itself {error, Msg2} = - ?PRIM_FILE_call(rename, Handle, [DirName2, Name2foo]), + ?PRIM_FILE:rename(DirName2, Name2foo), io:format("Errmsg2: ~p",[Msg2]), ok. @@ -1657,165 +1497,19 @@ e_del_dir(Config) when is_list(Config) -> ok. -%% Trying reading and positioning from a compressed file. - -read_compressed(Config) when is_list(Config) -> - Data = proplists:get_value(data_dir, Config), - Real = filename:join(Data, "realmen.html.gz"), - {ok, Fd} = ?PRIM_FILE:open(Real, [read, compressed]), - try_read_file(Fd). - -%% Trying reading and positioning from an uncompressed file, -%% but with the compressed flag given. - -read_not_really_compressed(Config) when is_list(Config) -> - Data = proplists:get_value(data_dir, Config), - Priv = proplists:get_value(priv_dir, Config), - - %% The file realmen.html might have got CRs added (by WinZip). - %% Remove them, or the file positions will not be correct. - - Real = filename:join(Data, "realmen.html"), - RealPriv = filename:join(Priv, - atom_to_list(?MODULE)++"_realmen.html"), - {ok, RealDataBin} = ?PRIM_FILE:read_file(Real), - RealData = remove_crs(binary_to_list(RealDataBin), []), - ok = ?PRIM_FILE:write_file(RealPriv, RealData), - {ok, Fd} = ?PRIM_FILE:open(RealPriv, [read, compressed]), - try_read_file(Fd). - -remove_crs([$\r|Rest], Result) -> - remove_crs(Rest, Result); -remove_crs([C|Rest], Result) -> - remove_crs(Rest, [C|Result]); -remove_crs([], Result) -> - lists:reverse(Result). - -try_read_file(Fd) -> - %% Seek to the current position (nothing should happen). - - {ok, 0} = ?PRIM_FILE:position(Fd, 0), - {ok, 0} = ?PRIM_FILE:position(Fd, {cur, 0}), - - %% Read a few lines from a compressed file. - - ShouldBe = "<TITLE>Real Programmers Don't Use PASCAL</TITLE>\n", - {ok, ShouldBe} = ?PRIM_FILE:read(Fd, length(ShouldBe)), - - %% Now seek forward. - - {ok, 381} = ?PRIM_FILE:position(Fd, 381), - Back = "Back in the good old days -- the \"Golden Era\" " ++ - "of computers, it was\n", - {ok, Back} = ?PRIM_FILE:read(Fd, length(Back)), - - %% Try to search forward relative to the current position. - - {ok, CurPos} = ?PRIM_FILE:position(Fd, {cur, 0}), - RealPos = 4273, - {ok, RealPos} = ?PRIM_FILE:position(Fd, {cur, RealPos-CurPos}), - RealProg = "<LI> Real Programmers aren't afraid to use GOTOs.\n", - {ok, RealProg} = ?PRIM_FILE:read(Fd, length(RealProg)), - - %% Seek backward. - - AfterTitle = length("<TITLE>"), - {ok, AfterTitle} = ?PRIM_FILE:position(Fd, AfterTitle), - Title = "Real Programmers Don't Use PASCAL</TITLE>\n", - {ok, Title} = ?PRIM_FILE:read(Fd, length(Title)), - - %% Done. - - ?PRIM_FILE:close(Fd), - ok. - -write_compressed(Config) when is_list(Config) -> - Priv = proplists:get_value(priv_dir, Config), - MyFile = filename:join(Priv, - atom_to_list(?MODULE)++"_test.gz"), - - %% Write a file. - - {ok, Fd} = ?PRIM_FILE:open(MyFile, [write, compressed]), - {ok, 0} = ?PRIM_FILE:position(Fd, 0), - Prefix = "hello\n", - End = "end\n", - ok = ?PRIM_FILE:write(Fd, Prefix), - {ok, 143} = ?PRIM_FILE:position(Fd, 143), - ok = ?PRIM_FILE:write(Fd, End), - ok = ?PRIM_FILE:close(Fd), - - %% Read the file and verify the contents. - - {ok, Fd1} = ?PRIM_FILE:open(MyFile, [read, compressed]), - {ok, Prefix} = ?PRIM_FILE:read(Fd1, length(Prefix)), - Second = lists:duplicate(143-length(Prefix), 0) ++ End, - {ok, Second} = ?PRIM_FILE:read(Fd1, length(Second)), - ok = ?PRIM_FILE:close(Fd1), - - %% Ensure that the file is compressed. - - TotalSize = 143 + length(End), - case ?PRIM_FILE:read_file_info(MyFile) of - {ok, #file_info{size=Size}} when Size < TotalSize -> - ok; - {ok, #file_info{size=Size}} when Size == TotalSize -> - ct:fail(file_not_compressed) - end, - - %% Write again to ensure that the file is truncated. - - {ok, Fd2} = ?PRIM_FILE:open(MyFile, [write, compressed]), - NewString = "aaaaaaaaaaa", - ok = ?PRIM_FILE:write(Fd2, NewString), - ok = ?PRIM_FILE:close(Fd2), - {ok, Fd3} = ?PRIM_FILE:open(MyFile, [read, compressed]), - {ok, NewString} = ?PRIM_FILE:read(Fd3, 1024), - ok = ?PRIM_FILE:close(Fd3), - - ok. - -compress_errors(Config) when is_list(Config) -> - Data = proplists:get_value(data_dir, Config), - {error, enoent} = ?PRIM_FILE:open("non_existing__", - [compressed, read]), - {error, einval} = ?PRIM_FILE:open("non_existing__", - [compressed, read, write]), - - %% Read a corrupted .gz file. - - Corrupted = filename:join(Data, "corrupted.gz"), - {ok, Fd} = ?PRIM_FILE:open(Corrupted, [read, compressed]), - {error, eio} = ?PRIM_FILE:read(Fd, 100), - ?PRIM_FILE:close(Fd), - - ok. - - -%% Test creating a hard link. -make_link_a(Config) when is_list(Config) -> - make_link(Config, [], "_a"). - -%% Test creating a hard link. -make_link_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = make_link(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - Result. - -make_link(Config, Handle, Suffix) -> +make_link(Config) when is_list(Config) -> RootDir = proplists:get_value(priv_dir, Config), NewDir = filename:join(RootDir, atom_to_list(?MODULE) - ++"_make_link"++Suffix), - ok = ?PRIM_FILE_call(make_dir, Handle, [NewDir]), + ++"_make_link"), + ok = ?PRIM_FILE:make_dir(NewDir), Name = filename:join(NewDir, "a_file"), ok = ?PRIM_FILE:write_file(Name, "some contents\n"), Alias = filename:join(NewDir, "an_alias"), Result = - case ?PRIM_FILE_call(make_link, Handle, [Name, Alias]) of + case ?PRIM_FILE:make_link(Name, Alias) of {error, enotsup} -> {skipped, "Links not supported on this platform"}; ok -> @@ -1826,12 +1520,12 @@ make_link(Config, Handle, Suffix) -> %% since they are not used on symbolic links. {ok, Info} = - ?PRIM_FILE_call(read_link_info, Handle, [Name]), + ?PRIM_FILE:read_link_info(Name), {ok, Info} = - ?PRIM_FILE_call(read_link_info, Handle, [Alias]), + ?PRIM_FILE:read_link_info(Alias), #file_info{links = 2, type = regular} = Info, {error, eexist} = - ?PRIM_FILE_call(make_link, Handle, [Name, Alias]), + ?PRIM_FILE:make_link(Name, Alias), ok end, @@ -1843,30 +1537,19 @@ read_link_info_for_non_link(Config) when is_list(Config) -> {ok, #file_info{type=directory}} = ?PRIM_FILE:read_link_info("."), ok. -%% Test operations on symbolic links (for Unix). -symlinks_a(Config) when is_list(Config) -> - symlinks(Config, [], "_a"). - -%% Test operations on symbolic links (for Unix). -symlinks_b(Config) when is_list(Config) -> - {ok, Handle} = ?PRIM_FILE:start(), - Result = symlinks(Config, Handle, "_b"), - ok = ?PRIM_FILE:stop(Handle), - Result. - -symlinks(Config, Handle, Suffix) -> +symlinks(Config) when is_list(Config) -> RootDir = proplists:get_value(priv_dir, Config), NewDir = filename:join(RootDir, atom_to_list(?MODULE) - ++"_make_symlink"++Suffix), - ok = ?PRIM_FILE_call(make_dir, Handle, [NewDir]), + ++"_make_symlink"), + ok = ?PRIM_FILE:make_dir(NewDir), Name = filename:join(NewDir, "a_plain_file"), ok = ?PRIM_FILE:write_file(Name, "some stupid content\n"), Alias = filename:join(NewDir, "a_symlink_alias"), Result = - case ?PRIM_FILE_call(make_symlink, Handle, [Name, Alias]) of + case ?PRIM_FILE:make_symlink(Name, Alias) of {error, enotsup} -> {skipped, "Links not supported on this platform"}; {error, eperm} -> @@ -1874,20 +1557,20 @@ symlinks(Config, Handle, Suffix) -> {skipped, "Windows user not privileged to create links"}; ok -> {ok, Info1} = - ?PRIM_FILE_call(read_file_info, Handle, [Name]), + ?PRIM_FILE:read_file_info(Name), {ok, Info1} = - ?PRIM_FILE_call(read_file_info, Handle, [Alias]), + ?PRIM_FILE:read_file_info(Alias), {ok, Info1} = - ?PRIM_FILE_call(read_link_info, Handle, [Name]), + ?PRIM_FILE:read_link_info(Name), #file_info{links = 1, type = regular} = Info1, {ok, Info2} = - ?PRIM_FILE_call(read_link_info, Handle, [Alias]), + ?PRIM_FILE:read_link_info(Alias), #file_info{links=1, type=symlink} = Info2, {ok, Name} = - ?PRIM_FILE_call(read_link, Handle, [Alias]), + ?PRIM_FILE:read_link(Alias), {ok, Name} = - ?PRIM_FILE_call(read_link_all, Handle, [Alias]), + ?PRIM_FILE:read_link_all(Alias), %% If all is good, delete dir again (avoid hanging dir on windows) rm_rf(?PRIM_FILE,NewDir), ok @@ -1907,10 +1590,9 @@ list_dir_limit(Config) when is_list(Config) -> RootDir = proplists:get_value(priv_dir, Config), NewDir = filename:join(RootDir, atom_to_list(?MODULE)++"_list_dir_limit"), - {ok, Handle1} = ?PRIM_FILE:start(), - ok = ?PRIM_FILE_call(make_dir, Handle1, [NewDir]), + ok = ?PRIM_FILE:make_dir(NewDir), Ref = erlang:start_timer(MaxTime*1000, self(), []), - Result = list_dir_limit_loop(NewDir, Handle1, Ref, MaxNumber, 0), + Result = list_dir_limit_loop(NewDir, Ref, MaxNumber, 0), Time = case erlang:cancel_timer(Ref) of false -> MaxTime; T -> MaxTime - (T div 1000) @@ -1920,21 +1602,18 @@ list_dir_limit(Config) when is_list(Config) -> {error, _Reason, N} -> N; _ -> 0 end, - {ok, Handle2} = ?PRIM_FILE:start(), - list_dir_limit_cleanup(NewDir, Handle2, Number, 0), - ok = ?PRIM_FILE:stop(Handle1), - ok = ?PRIM_FILE:stop(Handle2), + list_dir_limit_cleanup(NewDir, Number, 0), {ok, Number} = Result, {comment, "Created " ++ integer_to_list(Number) ++ " files in " ++ integer_to_list(Time) ++ " seconds."}. -list_dir_limit_loop(Dir, Handle, _Ref, N, Cnt) when Cnt >= N -> - list_dir_check(Dir, Handle, Cnt); -list_dir_limit_loop(Dir, Handle, Ref, N, Cnt) -> +list_dir_limit_loop(Dir, _Ref, N, Cnt) when Cnt >= N -> + list_dir_check(Dir, Cnt); +list_dir_limit_loop(Dir, Ref, N, Cnt) -> receive {timeout, Ref, []} -> - list_dir_check(Dir, Handle, Cnt) + list_dir_check(Dir, Cnt) after 0 -> Name = integer_to_list(Cnt), case ?PRIM_FILE:write_file(filename:join(Dir, Name), Name) of @@ -1942,23 +1621,23 @@ list_dir_limit_loop(Dir, Handle, Ref, N, Cnt) -> Next = Cnt + 1, case Cnt rem 100 of 0 -> - case list_dir_check(Dir, Handle, Next) of + case list_dir_check(Dir, Next) of {ok, Next} -> list_dir_limit_loop( - Dir, Handle, Ref, N, Next); + Dir, Ref, N, Next); Other -> Other end; _ -> - list_dir_limit_loop(Dir, Handle, Ref, N, Next) + list_dir_limit_loop(Dir, Ref, N, Next) end; {error, Reason} -> {error, Reason, Cnt} end end. -list_dir_check(Dir, Handle, Cnt) -> - case ?PRIM_FILE:list_dir(Handle, Dir) of +list_dir_check(Dir, Cnt) -> + case ?PRIM_FILE:list_dir(Dir) of {ok, ListDir} -> case length(ListDir) of Cnt -> @@ -1975,18 +1654,18 @@ list_dir_check(Dir, Handle, Cnt) -> %% Deletes N files while ignoring errors, then continues deleting %% as long as they exist. -list_dir_limit_cleanup(Dir, Handle, N, Cnt) when Cnt >= N -> +list_dir_limit_cleanup(Dir, N, Cnt) when Cnt >= N -> Name = integer_to_list(Cnt), - case ?PRIM_FILE:delete(Handle, filename:join(Dir, Name)) of + case ?PRIM_FILE:delete(filename:join(Dir, Name)) of ok -> - list_dir_limit_cleanup(Dir, Handle, N, Cnt+1); + list_dir_limit_cleanup(Dir, N, Cnt+1); _ -> ok end; -list_dir_limit_cleanup(Dir, Handle, N, Cnt) -> +list_dir_limit_cleanup(Dir, N, Cnt) -> Name = integer_to_list(Cnt), - ?PRIM_FILE:delete(Handle, filename:join(Dir, Name)), - list_dir_limit_cleanup(Dir, Handle, N, Cnt+1). + ?PRIM_FILE:delete(filename:join(Dir, Name)), + list_dir_limit_cleanup(Dir, N, Cnt+1). %%% %%% Test list_dir() on a non-existing pathname. @@ -1995,7 +1674,7 @@ list_dir_limit_cleanup(Dir, Handle, N, Cnt) -> list_dir_error(Config) -> Priv = proplists:get_value(priv_dir, Config), NonExisting = filename:join(Priv, "non-existing-dir"), - {error,enoent} = prim_file:list_dir(NonExisting), + {error,enoent} = ?PRIM_FILE:list_dir(NonExisting), ok. %%% @@ -2063,7 +1742,7 @@ do_run_large_file_test(Config, Run, Name0) -> {'DOWN',Mref,_,_,_} -> ok; {Tester,done} -> ok end, - prim_file:delete(Name) + ?PRIM_FILE:delete(Name) end), %% Run the test case. @@ -2108,12 +1787,25 @@ free_memory() -> {value, {buffered_memory, Buffed}} -> Buffed; false -> 0 end), - TotFree div (1024*1024) + usable_mem(TotFree) div (1024*1024) catch error : undef -> ct:fail({"os_mon not built"}) end. +usable_mem(Memory) -> + case test_server:is_valgrind() of + true -> + %% Valgrind uses extra memory for the V- and A-bits. + %% http://valgrind.org/docs/manual/mc-manual.html#mc-manual.value + %% Docs says it uses "compression to represent the V bits compactly" + %% but let's be conservative and cut usable memory in half. + Memory div 2; + false -> + Memory + end. + + %%%----------------------------------------------------------------- %%% Utilities rm_rf(Mod,Dir) -> diff --git a/lib/kernel/test/sendfile_SUITE.erl b/lib/kernel/test/sendfile_SUITE.erl index bfa564c32c..0c0b1cbcb6 100644 --- a/lib/kernel/test/sendfile_SUITE.erl +++ b/lib/kernel/test/sendfile_SUITE.erl @@ -23,30 +23,41 @@ -include_lib("common_test/include/ct.hrl"). -include_lib("kernel/include/file.hrl"). --compile(export_all). - -all() -> [{group,async_threads}, - {group,no_async_threads}]. - -groups() -> - [{async_threads,[],tcs()}, - {no_async_threads,[],tcs()}]. - -tcs() -> - [t_sendfile_small - ,t_sendfile_big_all - ,t_sendfile_big_size - ,t_sendfile_many_small - ,t_sendfile_partial - ,t_sendfile_offset - ,t_sendfile_sendafter - ,t_sendfile_recvafter - ,t_sendfile_recvafter_remoteclose - ,t_sendfile_sendduring - ,t_sendfile_recvduring - ,t_sendfile_closeduring - ,t_sendfile_crashduring - ]. +-export([all/0, init_per_suite/1, end_per_suite/1, init_per_testcase/2]). + +-export([sendfile_server/2, sendfile_do_recv/2, init/1, handle_event/2]). + +-export( + [t_sendfile_small/1, + t_sendfile_big_all/1, + t_sendfile_big_size/1, + t_sendfile_many_small/1, + t_sendfile_partial/1, + t_sendfile_offset/1, + t_sendfile_sendafter/1, + t_sendfile_recvafter/1, + t_sendfile_recvafter_remoteclose/1, + t_sendfile_sendduring/1, + t_sendfile_recvduring/1, + t_sendfile_closeduring/1, + t_sendfile_crashduring/1, + t_sendfile_arguments/1]). + +all() -> + [t_sendfile_small, + t_sendfile_big_all, + t_sendfile_big_size, + t_sendfile_many_small, + t_sendfile_partial, + t_sendfile_offset, + t_sendfile_sendafter, + t_sendfile_recvafter, + t_sendfile_recvafter_remoteclose, + t_sendfile_sendduring, + t_sendfile_recvduring, + t_sendfile_closeduring, + t_sendfile_crashduring, + t_sendfile_arguments]. init_per_suite(Config) -> case {os:type(),os:version()} of @@ -72,28 +83,18 @@ init_per_suite(Config) -> end_per_suite(Config) -> file:delete(proplists:get_value(big_file, Config)). -init_per_group(async_threads,Config) -> - case erlang:system_info(thread_pool_size) of - 0 -> - {skip,"No async threads"}; - _ -> - [{sendfile_opts,[{use_threads,true}]}|Config] - end; -init_per_group(no_async_threads,Config) -> - [{sendfile_opts,[{use_threads,false}]}|Config]. - -end_per_group(_,_Config) -> - ok. - init_per_testcase(TC,Config) when TC == t_sendfile_recvduring; TC == t_sendfile_sendduring -> Filename = proplists:get_value(small_file, Config), Send = fun(Sock) -> {_Size, Data} = sendfile_file_info(Filename), - {ok,D} = file:open(Filename, [raw,binary,read]), - prim_file:sendfile(D, Sock, 0, 0, 0, - [],[],[]), + {ok,Fd} = file:open(Filename, [raw,binary,read]), + %% Determine whether the driver has native support by + %% hitting the raw module directly; file:sendfile/5 will + %% land in the fallback if it doesn't. + RawModule = Fd#file_descriptor.module, + {ok, _Ignored} = RawModule:sendfile(Fd,Sock,0,0,0,[],[],[]), Data end, @@ -105,9 +106,8 @@ init_per_testcase(TC,Config) when TC == t_sendfile_recvduring; ct:log("Error: ~p",[Error]), {skip,"Not supported"} end; -init_per_testcase(_Tc,Config) -> - Config ++ [{sendfile_opts,[{use_threads,false}]}]. - +init_per_testcase(_TC,Config) -> + Config. t_sendfile_small(Config) when is_list(Config) -> Filename = proplists:get_value(small_file, Config), @@ -124,7 +124,7 @@ t_sendfile_small(Config) when is_list(Config) -> t_sendfile_many_small(Config) when is_list(Config) -> Filename = proplists:get_value(small_file, Config), FileOpts = proplists:get_value(file_opts, Config, []), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), error_logger:add_report_handler(?MODULE,[self()]), @@ -151,7 +151,7 @@ t_sendfile_many_small(Config) when is_list(Config) -> t_sendfile_big_all(Config) when is_list(Config) -> Filename = proplists:get_value(big_file, Config), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), Send = fun(Sock) -> {ok, #file_info{size = Size}} = @@ -165,7 +165,7 @@ t_sendfile_big_all(Config) when is_list(Config) -> t_sendfile_big_size(Config) -> Filename = proplists:get_value(big_file, Config), FileOpts = proplists:get_value(file_opts, Config, []), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), SendAll = fun(Sock) -> {ok, #file_info{size = Size}} = @@ -180,7 +180,7 @@ t_sendfile_big_size(Config) -> t_sendfile_partial(Config) -> Filename = proplists:get_value(small_file, Config), FileOpts = proplists:get_value(file_opts, Config, []), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), SendSingle = fun(Sock) -> {_Size, <<Data:5/binary,_/binary>>} = @@ -217,7 +217,7 @@ t_sendfile_partial(Config) -> t_sendfile_offset(Config) -> Filename = proplists:get_value(small_file, Config), FileOpts = proplists:get_value(file_opts, Config, []), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), Send = fun(Sock) -> {_Size, <<_:5/binary,Data:3/binary,_/binary>> = AllData} = @@ -233,7 +233,7 @@ t_sendfile_offset(Config) -> t_sendfile_sendafter(Config) -> Filename = proplists:get_value(small_file, Config), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), Send = fun(Sock) -> {Size, Data} = sendfile_file_info(Filename), @@ -246,7 +246,7 @@ t_sendfile_sendafter(Config) -> t_sendfile_recvafter(Config) -> Filename = proplists:get_value(small_file, Config), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), Send = fun(Sock) -> {Size, Data} = sendfile_file_info(Filename), @@ -279,7 +279,7 @@ t_sendfile_recvafter_remoteclose(Config) -> t_sendfile_sendduring(Config) -> Filename = proplists:get_value(big_file, Config), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), Send = fun(Sock) -> {ok, #file_info{size = Size}} = @@ -296,7 +296,7 @@ t_sendfile_sendduring(Config) -> t_sendfile_recvduring(Config) -> Filename = proplists:get_value(big_file, Config), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), Send = fun(Sock) -> {ok, #file_info{size = Size}} = @@ -315,7 +315,7 @@ t_sendfile_recvduring(Config) -> t_sendfile_closeduring(Config) -> Filename = proplists:get_value(big_file, Config), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), Send = fun(Sock,SFServPid) -> spawn_link(fun() -> @@ -345,7 +345,7 @@ t_sendfile_closeduring(Config) -> t_sendfile_crashduring(Config) -> Filename = proplists:get_value(big_file, Config), - SendfileOpts = proplists:get_value(sendfile_opts, Config), + SendfileOpts = proplists:get_value(sendfile_opts, Config, []), error_logger:add_report_handler(?MODULE,[self()]), @@ -373,6 +373,36 @@ t_sendfile_crashduring(Config) -> end end. +t_sendfile_arguments(Config) -> + Filename = proplists:get_value(small_file, Config), + + {ok, Listener} = gen_tcp:listen(0, + [{packet, 0}, {active, false}, {reuseaddr, true}]), + {ok, Port} = inet:port(Listener), + + ErrorCheck = + fun(Reason, Offset, Length, Opts) -> + {ok, Sender} = gen_tcp:connect({127, 0, 0, 1}, Port, + [{packet, 0}, {active, false}]), + {ok, Receiver} = gen_tcp:accept(Listener), + {ok, Fd} = file:open(Filename, [read, raw]), + {error, Reason} = file:sendfile(Fd, Sender, Offset, Length, Opts), + gen_tcp:close(Receiver), + gen_tcp:close(Sender), + file:close(Fd) + end, + + ErrorCheck(einval, -1, 0, []), + ErrorCheck(einval, 0, -1, []), + ErrorCheck(badarg, gurka, 0, []), + ErrorCheck(badarg, 0, gurka, []), + ErrorCheck(badarg, 0, 0, gurka), + ErrorCheck(badarg, 0, 0, [{chunk_size, gurka}]), + + gen_tcp:close(Listener), + + ok. + %% Generic sendfile server code sendfile_send(Send) -> sendfile_send({127,0,0,1},Send). diff --git a/lib/kernel/test/zlib_SUITE.erl b/lib/kernel/test/zlib_SUITE.erl index 7be7e503df..f203ef878f 100644 --- a/lib/kernel/test/zlib_SUITE.erl +++ b/lib/kernel/test/zlib_SUITE.erl @@ -166,7 +166,7 @@ api_deflateInit(Config) when is_list(Config) -> ?m(ok, zlib:deflateInit(Z12,default,deflated,-Wbits,8,default)), ?m(ok,zlib:close(Z11)), ?m(ok,zlib:close(Z12)) - end, lists:seq(8, 15)), + end, lists:seq(9, 15)), lists:foreach(fun(MemLevel) -> Z = zlib:open(), @@ -213,12 +213,46 @@ api_deflateReset(Config) when is_list(Config) -> %% Test deflateParams. api_deflateParams(Config) when is_list(Config) -> + Levels = [none, default, best_speed, best_compression] ++ lists:seq(0, 9), + Strategies = [filtered, huffman_only, rle, default], + Z1 = zlib:open(), ?m(ok, zlib:deflateInit(Z1, default)), - ?m(L when is_list(L), zlib:deflate(Z1, <<1,1,1,1,1,1,1,1,1>>, none)), - ?m(ok, zlib:deflateParams(Z1, best_compression, huffman_only)), - ?m(L when is_list(L), zlib:deflate(Z1, <<1,1,1,1,1,1,1,1,1>>, sync)), - ?m(ok, zlib:close(Z1)). + + ApiTest = + fun(Level, Strategy) -> + ?m(ok, zlib:deflateParams(Z1, Level, Strategy)), + ?m(ok, zlib:deflateReset(Z1)) + end, + + [ ApiTest(Level, Strategy) || Level <- Levels, Strategy <- Strategies ], + + ?m(ok, zlib:close(Z1)), + + FlushTest = + fun FlushTest(Size, Level, Strategy) -> + Z = zlib:open(), + ok = zlib:deflateInit(Z, default), + Data = gen_determ_rand_bytes(Size), + case zlib:deflate(Z, Data, none) of + [<<120, 156>>] -> + %% All data is present in the internal zlib state, and will + %% be flushed on deflateParams. + + ok = zlib:deflateParams(Z, Level, Strategy), + Compressed = [<<120, 156>>, zlib:deflate(Z, <<>>, finish)], + Data = zlib:uncompress(Compressed), + zlib:close(Z), + + FlushTest(Size + (1 bsl 10), Level, Strategy); + _Other -> + ok + end + end, + + [ FlushTest(1, Level, Strategy) || Level <- Levels, Strategy <- Strategies ], + + ok. %% Test deflate. api_deflate(Config) when is_list(Config) -> @@ -652,6 +686,11 @@ api_g_un_zip(Config) when is_list(Config) -> Concatenated = <<Bin/binary, Bin/binary>>, ?m(Concatenated, zlib:gunzip([Comp, Comp])), + %% Don't explode if the uncompressed size is a perfect multiple of the + %% internal inflate chunk size. + ChunkSizedData = <<0:16384/unit:8>>, + ?m(ChunkSizedData, zlib:gunzip(zlib:gzip(ChunkSizedData))), + %% Bad CRC; bad length. BadCrc = bad_crc_data(), ?m(?EXIT(data_error),(catch zlib:gunzip(BadCrc))), @@ -762,13 +801,13 @@ zip_usage({run,ZIP,ORIG}) -> ?m(ok, zlib:deflateInit(Z, default, deflated, -15, 8, default)), C2 = zlib:deflate(Z, ORIG, finish), - ?m(true, C1 == list_to_binary(C2)), + ?m(ORIG, zlib:unzip(C2)), ?m(ok, zlib:deflateEnd(Z)), ?m(ok, zlib:deflateInit(Z, none, deflated, -15, 8, filtered)), ?m(ok, zlib:deflateParams(Z, default, default)), C3 = zlib:deflate(Z, ORIG, finish), - ?m(true, C1 == list_to_binary(C3)), + ?m(ORIG, zlib:unzip(C3)), ?m(ok, zlib:deflateEnd(Z)), ok = zlib:close(Z), diff --git a/lib/kernel/vsn.mk b/lib/kernel/vsn.mk index cef54dd41a..106bda01ca 100644 --- a/lib/kernel/vsn.mk +++ b/lib/kernel/vsn.mk @@ -1 +1 @@ -KERNEL_VSN = 5.4 +KERNEL_VSN = 5.4.1 diff --git a/lib/megaco/doc/src/notes.xml b/lib/megaco/doc/src/notes.xml index deb2bfcff3..54e048a172 100644 --- a/lib/megaco/doc/src/notes.xml +++ b/lib/megaco/doc/src/notes.xml @@ -37,7 +37,22 @@ section is the version number of Megaco.</p> - <section><title>Megaco 3.18.2</title> + <section><title>Megaco 3.18.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + +<section><title>Megaco 3.18.2</title> <section><title>Improvements and New Features</title> <list> diff --git a/lib/megaco/vsn.mk b/lib/megaco/vsn.mk index 9c6ba5bba0..a4f7de7f07 100644 --- a/lib/megaco/vsn.mk +++ b/lib/megaco/vsn.mk @@ -19,6 +19,6 @@ # %CopyrightEnd% APPLICATION = megaco -MEGACO_VSN = 3.18.2 +MEGACO_VSN = 3.18.3 PRE_VSN = APP_VSN = "$(APPLICATION)-$(MEGACO_VSN)$(PRE_VSN)" diff --git a/lib/mnesia/doc/src/Makefile b/lib/mnesia/doc/src/Makefile index da7a9e9516..82fcf66256 100644 --- a/lib/mnesia/doc/src/Makefile +++ b/lib/mnesia/doc/src/Makefile @@ -48,6 +48,7 @@ XML_PART_FILES = \ XML_CHAPTER_FILES = \ Mnesia_chap1.xml \ + Mnesia_overview.xml \ Mnesia_chap2.xml \ Mnesia_chap3.xml \ Mnesia_chap4.xml \ diff --git a/lib/mnesia/doc/src/notes.xml b/lib/mnesia/doc/src/notes.xml index 026c6a89d7..ba94e913f5 100644 --- a/lib/mnesia/doc/src/notes.xml +++ b/lib/mnesia/doc/src/notes.xml @@ -39,7 +39,49 @@ thus constitutes one section in this document. The title of each section is the version number of Mnesia.</p> - <section><title>Mnesia 4.15.1</title> + <section><title>Mnesia 4.15.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Removed a quadratic behavior in startup. This change + implies that backend plugins (if used) must be set when + the schema is created or via configuration parameters + before mnesia is started.</p> + <p> + Own Id: OTP-14829 Aux Id: ERIERL-84 </p> + </item> + <item> + <p> + Bad timing could crash mnesia after a checkpoint was + deactivated and reactivated with the same checkpoint name + on different tables.</p> + <p> + Own Id: OTP-14841 Aux Id: ERIERL-113 </p> + </item> + </list> + </section> + +</section> + +<section><title>Mnesia 4.15.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Fix backup error handling, the real failure reason was + not returned.</p> + <p> + Own Id: OTP-14776 Aux Id: ERIERL-103 </p> + </item> + </list> + </section> + +</section> + +<section><title>Mnesia 4.15.1</title> <section><title>Improvements and New Features</title> <list> diff --git a/lib/mnesia/src/mnesia.erl b/lib/mnesia/src/mnesia.erl index b68b2de028..95f7d4afc1 100644 --- a/lib/mnesia/src/mnesia.erl +++ b/lib/mnesia/src/mnesia.erl @@ -151,7 +151,8 @@ {'snmp', SnmpStruct::term()} | {'storage_properties', [{Backend::module(), [BackendProp::_]}]} | {'type', 'set' | 'ordered_set' | 'bag'} | - {'local_content', boolean()}. + {'local_content', boolean()} | + {'user_properties', proplists:proplist()}. -type t_result(Res) :: {'atomic', Res} | {'aborted', Reason::term()}. -type activity() :: 'ets' | 'async_dirty' | 'sync_dirty' | 'transaction' | 'sync_transaction' | @@ -2681,7 +2682,7 @@ del_table_index(Tab, Ix) -> -spec transform_table(Tab::table(), Fun, [Attr]) -> t_result(ok) when Attr :: atom(), - Fun:: fun((Record::tuple()) -> Transformed::tuple()). + Fun:: fun((Record::tuple()) -> Transformed::tuple()) | ignore. transform_table(Tab, Fun, NewA) -> try val({Tab, record_name}) of OldRN -> mnesia_schema:transform_table(Tab, Fun, NewA, OldRN) @@ -2692,7 +2693,7 @@ transform_table(Tab, Fun, NewA) -> -spec transform_table(Tab::table(), Fun, [Attr], RecName) -> t_result(ok) when RecName :: atom(), Attr :: atom(), - Fun:: fun((Record::tuple()) -> Transformed::tuple()). + Fun:: fun((Record::tuple()) -> Transformed::tuple()) | ignore. transform_table(Tab, Fun, NewA, NewRN) -> mnesia_schema:transform_table(Tab, Fun, NewA, NewRN). diff --git a/lib/mnesia/src/mnesia_checkpoint.erl b/lib/mnesia/src/mnesia_checkpoint.erl index 2ff77326a9..8112378ffd 100644 --- a/lib/mnesia/src/mnesia_checkpoint.erl +++ b/lib/mnesia/src/mnesia_checkpoint.erl @@ -857,9 +857,9 @@ retainer_loop(Cp = #checkpoint_args{is_activated=false, name=Name}) -> retainer_loop(Cp = #checkpoint_args{name=Name}) -> receive {_From, {retain, Tid, Tab, Key, OldRecs}} -> - R = val({Tab, {retainer, Name}}), + R = ?catch_val({Tab, {retainer, Name}}), PendingTab = Cp#checkpoint_args.pending_tab, - case R#retainer.really_retain of + case is_record(R, retainer) andalso R#retainer.really_retain of true -> Store = R#retainer.store, try true = ets:member(PendingTab, Tid), diff --git a/lib/mnesia/src/mnesia_log.erl b/lib/mnesia/src/mnesia_log.erl index 55b1d6e419..a2de23a2a3 100644 --- a/lib/mnesia/src/mnesia_log.erl +++ b/lib/mnesia/src/mnesia_log.erl @@ -752,8 +752,8 @@ abort_write(B, What, Args, Reason) -> Opaque = B#backup_args.opaque, dbg_out("Failed to perform backup. M=~p:F=~tp:A=~tp -> ~tp~n", [Mod, What, Args, Reason]), - try apply(Mod, abort_write, [Opaque]) of - {ok, _Res} -> throw({error, Reason}) + try {ok, _Res} = apply(Mod, abort_write, [Opaque]) of + _ -> throw({error, Reason}) catch _:Other -> error("Failed to abort backup. ~p:~tp~tp -> ~tp~n", [Mod, abort_write, [Opaque], Other]), diff --git a/lib/mnesia/src/mnesia_schema.erl b/lib/mnesia/src/mnesia_schema.erl index 83cc19c678..71952af31c 100644 --- a/lib/mnesia/src/mnesia_schema.erl +++ b/lib/mnesia/src/mnesia_schema.erl @@ -952,19 +952,9 @@ get_index_plugins() -> get_schema_user_property(mnesia_index_plugins). get_schema_user_property(Key) -> - Tab = schema, - %% Must work reliably both within transactions and outside of transactions - Res = case get(mnesia_activity_state) of - undefined -> - dirty_read_table_property(Tab, Key); - _ -> - do_read_table_property(Tab, Key) - end, - case Res of - undefined -> - []; - {_, Types} -> - Types + case dirty_read_table_property(schema, Key) of + undefined -> []; + {_, Types} -> Types end. get_ext_types_disc() -> diff --git a/lib/mnesia/vsn.mk b/lib/mnesia/vsn.mk index a95f468ba2..45f811846d 100644 --- a/lib/mnesia/vsn.mk +++ b/lib/mnesia/vsn.mk @@ -1 +1 @@ -MNESIA_VSN = 4.15.1 +MNESIA_VSN = 4.15.3 diff --git a/lib/observer/doc/src/Makefile b/lib/observer/doc/src/Makefile index a3b0663041..11bfee1bdb 100644 --- a/lib/observer/doc/src/Makefile +++ b/lib/observer/doc/src/Makefile @@ -48,12 +48,12 @@ XML_PART_FILES = \ part.xml XML_CHAPTER_FILES = \ + introduction_ug.xml \ crashdump_ug.xml \ etop_ug.xml \ observer_ug.xml \ ttb_ug.xml \ - notes.xml \ - notes_history.xml + notes.xml BOOK_FILES = book.xml diff --git a/lib/observer/doc/src/notes.xml b/lib/observer/doc/src/notes.xml index 05ea550964..96cd89b375 100644 --- a/lib/observer/doc/src/notes.xml +++ b/lib/observer/doc/src/notes.xml @@ -32,6 +32,73 @@ <p>This document describes the changes made to the Observer application.</p> +<section><title>Observer 2.6</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + A bug introduced in OTP-20 would make Crashdump Viewer + crash when trying to expand an empty binary. This is now + corrected.</p> + <p> + Own Id: OTP-14642</p> + </item> + <item> + <p> + If a match spec in the config file contained more than + one clause, observer would earlier crash when trying to + display it in the GUI. This is now corrected.</p> + <p> + Own Id: OTP-14643 Aux Id: ERL-489 </p> + </item> + <item> + <p>Writing of crash dumps is significantly faster.</p> + <p>Maps are now included in crash dumps.</p> + <p>Constants terms would only be shown in one process, + while other processes referencing the same constant term + would show a marker for incomplete heap. </p> + <p> + Own Id: OTP-14685 Aux Id: OTP-14611, OTP-14603, OTP-14595 </p> + </item> + </list> + </section> + + + <section><title>Improvements and New Features</title> + <list> + <item> + <p>Binaries and some other data in crash dumps are now + encoded in base64 (instead of in hex), which will reduce + the size of crash dumps.</p> + <p>A few bugs in the handling of sub binaries in + <c>crashdump_viewer</c> have been fixed.</p> + <p> + Own Id: OTP-14686</p> + </item> + <item> + <p> + In order to allow future improvements, Crashdump Viewer + now checks the version tag of the crashdump to see that + it is a known format. If the crashdump version is newer + than Crashdump Viewer is prepared to read, then an + information dialog is displayed before Crashdump Viewer + terminates.</p> + <p> + If an incomplete process heap is discovered in a + crashdump, Crashdump Viewer will now display a warning + for this, similar to the warning displayed when a + crashdump is truncated. Incomplete heaps can occur if for + instance the literals are not included, which is the case + for all dumps prior to OTP-20.2.</p> + <p> + Own Id: OTP-14755</p> + </item> + </list> + </section> + +</section> + <section><title>Observer 2.5</title> <section><title>Improvements and New Features</title> diff --git a/lib/observer/include/etop.hrl b/lib/observer/include/etop.hrl index 002937e522..f8d370450b 100644 --- a/lib/observer/include/etop.hrl +++ b/lib/observer/include/etop.hrl @@ -18,4 +18,4 @@ %% %CopyrightEnd% %% --include("../../runtime_tools/include/observer_backend.hrl"). +-include_lib("runtime_tools/include/observer_backend.hrl"). diff --git a/lib/observer/src/cdv_bin_cb.erl b/lib/observer/src/cdv_bin_cb.erl index 5502869973..a4a542297c 100644 --- a/lib/observer/src/cdv_bin_cb.erl +++ b/lib/observer/src/cdv_bin_cb.erl @@ -71,6 +71,8 @@ hex_binary_fun(Bin) -> plain_html(io_lib:format("~s",[S])) end. +format_hex(<<>>,_) -> + []; format_hex(<<B1:4,B2:4>>,_) -> [integer_to_list(B1,16),integer_to_list(B2,16)]; format_hex(<<B1:4,B2:4,Bin/binary>>,0) -> diff --git a/lib/observer/src/cdv_detail_wx.erl b/lib/observer/src/cdv_detail_wx.erl index f6d282638a..6c4739042b 100644 --- a/lib/observer/src/cdv_detail_wx.erl +++ b/lib/observer/src/cdv_detail_wx.erl @@ -48,6 +48,7 @@ init([Id, Data, ParentFrame, Callback, App, Parent]) -> display_progress(ParentFrame,App), case Callback:get_details(Id, Data) of {ok,Details} -> + display_progress_pulse(Callback,Id), init(Id,ParentFrame,Callback,App,Parent,Details); {yes_no, Info, Fun} -> destroy_progress(App), @@ -69,8 +70,16 @@ display_progress(ParentFrame,cdv) -> "Reading data"); display_progress(_,_) -> ok. + +%% Display pulse while creating process detail page with much data +display_progress_pulse(cdv_proc_cb,Pid) -> + observer_lib:report_progress({ok,"Displaying data for "++Pid}), + observer_lib:report_progress({ok,start_pulse}); +display_progress_pulse(_,_) -> + ok. + destroy_progress(cdv) -> - observer_lib:destroy_progress_dialog(); + observer_lib:sync_destroy_progress_dialog(); destroy_progress(_) -> ok. diff --git a/lib/observer/src/cdv_info_wx.erl b/lib/observer/src/cdv_info_wx.erl index 7e416dd11a..07c28610e2 100644 --- a/lib/observer/src/cdv_info_wx.erl +++ b/lib/observer/src/cdv_info_wx.erl @@ -95,6 +95,10 @@ handle_cast(Msg, State) -> io:format("~p~p: Unhandled cast ~tp~n",[?MODULE, ?LINE, Msg]), {noreply, State}. +handle_event(#wx{obj=MoreEntry,event=#wxMouse{type=left_down},userData={more,More}}, State) -> + observer_lib:add_scroll_entries(MoreEntry,More), + {noreply, State}; + handle_event(#wx{event=#wxMouse{type=left_down},userData=Target}, State) -> cdv_virtual_list_wx:start_detail_win(Target), {noreply, State}; diff --git a/lib/observer/src/crashdump_viewer.erl b/lib/observer/src/crashdump_viewer.erl index 7f6bb9bdcd..bba97624a7 100644 --- a/lib/observer/src/crashdump_viewer.erl +++ b/lib/observer/src/crashdump_viewer.erl @@ -26,10 +26,25 @@ %% Tables %% ------ %% cdv_dump_index_table: This table holds all tags read from the -%% crashdump. Each tag indicates where the information about a -%% specific item starts. The table entry for a tag includes the start -%% position for this item-information. In a crash dump file, all tags -%% start with a "=" at the beginning of a line. +%% crashdump, except the 'binary' tag. Each tag indicates where the +%% information about a specific item starts. The table entry for a +%% tag includes the start position for this item-information. In a +%% crash dump file, all tags start with a "=" at the beginning of a +%% line. +%% +%% cdv_binary_index_table: This table holds all 'binary' tags. The hex +%% address for each binary is converted to its integer value before +%% storing Address -> Start Position in this table. The hex value of +%% the address is never used for lookup. +%% +%% cdv_reg_proc_table: This table holds mappings between pid and +%% registered name. This is used for timers and monitors. +%% +%% cdv_heap_file_chars: For each 'proc_heap' and 'literals' tag, this +%% table contains the number of characters to read from the crash dump +%% file. This is used for giving an indication in percent of the +%% progress when parsing this data. +%% %% %% Process state %% ------------- @@ -73,6 +88,9 @@ -export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, code_change/3]). +%% Test support +-export([get_dump_versions/0]). + %% Debug support -export([debug/1,stop_debug/0]). @@ -87,7 +105,10 @@ % line_head/1 function can return -define(not_available,"N/A"). -define(binary_size_progress_limit,10000). +-define(max_dump_version,[0,5]). +%% The value of the next define must be divisible by 4. +-define(base64_chunk_size, (4*256)). %% All possible tags - use macros in order to avoid misspelling in the code -define(abort,abort). @@ -126,6 +147,7 @@ -record(state,{file,dump_vsn,wordsize=4,num_atoms="unknown"}). +-record(dec_opts, {bin_addr_adj=0,base64=true}). %%%----------------------------------------------------------------- %%% Debugging @@ -294,6 +316,11 @@ port(Id) -> expand_binary(Pos) -> call({expand_binary,Pos}). +%%%----------------------------------------------------------------- +%%% For testing only - called from crashdump_viewer_SUITE +get_dump_versions() -> + call(get_dump_versions). + %%==================================================================== %% Server functions %%==================================================================== @@ -343,10 +370,12 @@ handle_call(general_info,_From,State=#state{file=File}) -> ets:insert(cdv_reg_proc_table, {cdv_dump_node_name,GenInfo#general_info.node_name}), {reply,{ok,GenInfo,TW},State#state{wordsize=WS, num_atoms=NumAtoms}}; -handle_call({expand_binary,{Offset,Size,Pos}},_From,State=#state{file=File}) -> +handle_call({expand_binary,{Offset,Size,Pos}},_From, + #state{file=File,dump_vsn=DumpVsn}=State) -> Fd = open(File), pos_bof(Fd,Pos), - {Bin,_Line} = get_binary(Offset,Size,bytes(Fd)), + DecodeOpts = get_decode_opts(DumpVsn), + {Bin,_Line} = get_binary(Offset,Size,bytes(Fd),DecodeOpts), close(Fd), {reply,{ok,Bin},State}; handle_call(procs_summary,_From,State=#state{file=File,wordsize=WS}) -> @@ -419,9 +448,11 @@ handle_call(loaded_mods,_From,State=#state{file=File}) -> TW = truncated_warning([?mod]), {_CC,_OC,Mods} = loaded_mods(File), {reply,{ok,Mods,TW},State}; -handle_call({loaded_mod_details,Mod},_From,State=#state{file=File}) -> +handle_call({loaded_mod_details,Mod},_From, + #state{dump_vsn=DumpVsn,file=File}=State) -> TW = truncated_warning([{?mod,Mod}]), - ModInfo = get_loaded_mod_details(File,Mod), + DecodeOpts = get_decode_opts(DumpVsn), + ModInfo = get_loaded_mod_details(File,Mod,DecodeOpts), {reply,{ok,ModInfo,TW},State}; handle_call(funs,_From,State=#state{file=File}) -> TW = truncated_warning([?fu]), @@ -455,8 +486,9 @@ handle_call(index_tables,_From,State=#state{file=File}) -> handle_call(schedulers,_From,State=#state{file=File}) -> Schedulers=schedulers(File), TW = truncated_warning([?scheduler]), - {reply,{ok,Schedulers,TW},State}. - + {reply,{ok,Schedulers,TW},State}; +handle_call(get_dump_versions,_From,State=#state{dump_vsn=DumpVsn}) -> + {reply,{ok,{?max_dump_version,DumpVsn}},State}. %%-------------------------------------------------------------------- @@ -781,10 +813,8 @@ parse_vsn_str(Str,WS) -> %%%----------------------------------------------------------------- -%%% Traverse crash dump and insert index in table for each heading -%%% -%%% Progress is reported during the time and MUST be checked with -%%% crashdump_viewer:get_progress/0 until it returns {ok,done}. +%%% Traverse crash dump and insert index in table for each heading. +%%% Progress is reported during the time. do_read_file(File) -> erase(?literals), %Clear literal cache. put(truncated,false), %Not truncated (yet). @@ -800,17 +830,21 @@ do_read_file(File) -> {Tag,Id,Rest,N1} = tag(Fd,TagAndRest,1), case Tag of ?erl_crash_dump -> - reset_tables(), - insert_index(Tag,Id,N1+1), - put_last_tag(Tag,""), - DumpVsn = [list_to_integer(L) || - L<-string:lexemes(Id,".")], - AddrAdj = get_bin_addr_adj(DumpVsn), - indexify(Fd,AddrAdj,Rest,N1), - end_progress(), - check_if_truncated(), - close(Fd), - {ok,DumpVsn}; + case check_dump_version(Id) of + {ok,DumpVsn} -> + reset_tables(), + insert_index(Tag,Id,N1+1), + put_last_tag(Tag,""), + DecodeOpts = get_decode_opts(DumpVsn), + indexify(Fd,DecodeOpts,Rest,N1), + end_progress(), + check_if_truncated(), + close(Fd), + {ok,DumpVsn}; + Error -> + close(Fd), + Error + end; _Other -> R = io_lib:format( "~ts is not an Erlang crash dump~n", @@ -838,7 +872,19 @@ do_read_file(File) -> {error,R} end. -indexify(Fd,AddrAdj,Bin,N) -> +check_dump_version(Vsn) -> + DumpVsn = [list_to_integer(L) || L<-string:lexemes(Vsn,".")], + if DumpVsn > ?max_dump_version -> + Info = + "This Crashdump Viewer is too old for the given " + "Erlang crash dump. Please use a newer version of " + "Crashdump Viewer.", + {error,Info}; + true -> + {ok,DumpVsn} + end. + +indexify(Fd,DecodeOpts,Bin,N) -> case binary:match(Bin,<<"\n=">>) of {Start,Len} -> Pos = Start+Len, @@ -851,7 +897,7 @@ indexify(Fd,AddrAdj,Bin,N) -> %% order to minimize lookup time. Key is the %% translated address. {HexAddr,_} = get_hex(Id), - Addr = HexAddr bor AddrAdj, + Addr = HexAddr bor DecodeOpts#dec_opts.bin_addr_adj, insert_binary_index(Addr,NewPos); _ -> insert_index(Tag,Id,NewPos) @@ -875,7 +921,7 @@ indexify(Fd,AddrAdj,Bin,N) -> end; _ -> ok end, - indexify(Fd,AddrAdj,Rest,N1); + indexify(Fd,DecodeOpts,Rest,N1); nomatch -> case progress_read(Fd) of {ok,Chunk0} when is_binary(Chunk0) -> @@ -886,7 +932,7 @@ indexify(Fd,AddrAdj,Bin,N) -> _ -> {Chunk0,N+byte_size(Bin)} end, - indexify(Fd,AddrAdj,Chunk,N1); + indexify(Fd,DecodeOpts,Chunk,N1); eof -> eof end @@ -1083,7 +1129,7 @@ get_proc_details(File,Pid,WS,DumpVsn) -> {{Stack,MsgQ,Dict},TW} = case truncated_warning([{?proc,Pid}]) of [] -> - {expand_memory(Fd,Pid,DumpVsn),[]}; + expand_memory(Fd,Pid,DumpVsn); TW0 -> {{[],[],[]},TW0} end, @@ -1194,7 +1240,7 @@ all_procinfo(Fd,Fun,Proc,WS,LineHead) -> "Last calls" -> get_procinfo(Fd,Fun,Proc#proc{last_calls=get_last_calls(Fd)},WS); "Link list" -> - {Links,Monitors,MonitoredBy} = parse_link_list(bytes(Fd),[],[],[]), + {Links,Monitors,MonitoredBy} = get_link_list(Fd), get_procinfo(Fd,Fun,Proc#proc{links=Links, monitors=Monitors, mon_by=MonitoredBy},WS); @@ -1276,86 +1322,64 @@ get_last_calls(Fd,<<>>,Acc,Lines) -> lists:reverse(Lines,[byte_list_to_string(lists:reverse(Acc))]) end. -parse_link_list([SB|Str],Links,Monitors,MonitoredBy) when SB==$[; SB==$] -> - parse_link_list(Str,Links,Monitors,MonitoredBy); -parse_link_list("#Port"++_=Str,Links,Monitors,MonitoredBy) -> - {Link,Rest} = parse_port(Str), - parse_link_list(Rest,[Link|Links],Monitors,MonitoredBy); -parse_link_list("<"++_=Str,Links,Monitors,MonitoredBy) -> - {Link,Rest} = parse_pid(Str), - parse_link_list(Rest,[Link|Links],Monitors,MonitoredBy); -parse_link_list("{to,"++Str,Links,Monitors,MonitoredBy) -> - {Mon,Rest} = parse_monitor(Str), - parse_link_list(Rest,Links,[Mon|Monitors],MonitoredBy); -parse_link_list("{from,"++Str,Links,Monitors,MonitoredBy) -> - {Mon,Rest} = parse_monitor(Str), - parse_link_list(Rest,Links,Monitors,[Mon|MonitoredBy]); -parse_link_list(", "++Rest,Links,Monitors,MonitoredBy) -> - parse_link_list(Rest,Links,Monitors,MonitoredBy); -parse_link_list([],Links,Monitors,MonitoredBy) -> - {lists:reverse(Links),lists:reverse(Monitors),lists:reverse(MonitoredBy)}; -parse_link_list(Unexpected,Links,Monitors,MonitoredBy) -> - io:format("WARNING: found unexpected data in link list:~n~ts~n",[Unexpected]), - parse_link_list([],Links,Monitors,MonitoredBy). - - -parse_port(Str) -> - {Port,Rest} = parse_link(Str,[]), - {{Port,Port},Rest}. - -parse_pid(Str) -> - {Pid,Rest} = parse_link(Str,[]), - {{Pid,Pid},Rest}. - -parse_monitor("{"++Str) -> - %% Named process - {Name,Node,Rest1} = parse_name_node(Str,[]), - Pid = get_pid_from_name(Name,Node), - case parse_link(string:trim(Rest1,leading,","),[]) of - {Ref,"}"++Rest2} -> - %% Bug in break.c - prints an extra "}" for remote - %% nodes... thus the strip - {{Pid,"{"++Name++","++Node++"} ("++Ref++")"}, - string:trim(Rest2,leading,"}")}; - {Ref,[]} -> - {{Pid,"{"++Name++","++Node++"} ("++Ref++")"},[]} - end; -parse_monitor(Str) -> - case parse_link(Str,[]) of - {Pid,","++Rest1} -> - case parse_link(Rest1,[]) of - {Ref,"}"++Rest2} -> - {{Pid,Pid++" ("++Ref++")"},Rest2}; - {Ref,[]} -> - {{Pid,Pid++" ("++Ref++")"},[]} - end; - {Pid,[]} -> - {{Pid,Pid++" (unknown_ref)"},[]} +get_link_list(Fd) -> + case get_chunk(Fd) of + {ok,<<"[",Bin/binary>>} -> + #{links:=Links, + mons:=Monitors, + mon_by:=MonitoredBy} = + get_link_list(Fd,Bin,#{links=>[],mons=>[],mon_by=>[]}), + {lists:reverse(Links), + lists:reverse(Monitors), + lists:reverse(MonitoredBy)}; + eof -> + {[],[],[]} end. -parse_link(">"++Rest,Acc) -> - {lists:reverse(Acc,">"),Rest}; -parse_link([H|T],Acc) -> - parse_link(T,[H|Acc]); -parse_link([],Acc) -> - %% truncated - {lists:reverse(Acc),[]}. +get_link_list(Fd,<<NL:8,_/binary>>=Bin,Acc) when NL=:=$\r; NL=:=$\n-> + skip(Fd,Bin), + Acc; +get_link_list(Fd,Bin,Acc) -> + case binary:split(Bin,[<<", ">>,<<"]">>]) of + [Link,Rest] -> + get_link_list(Fd,Rest,get_link(Link,Acc)); + [Incomplete] -> + case get_chunk(Fd) of + {ok,More} -> + get_link_list(Fd,<<Incomplete/binary,More/binary>>,Acc); + eof -> + Acc + end + end. -parse_name_node(","++Rest,Name) -> - parse_name_node(Rest,Name,[]); -parse_name_node([H|T],Name) -> - parse_name_node(T,[H|Name]); -parse_name_node([],Name) -> - %% truncated - {lists:reverse(Name),[],[]}. - -parse_name_node("}"++Rest,Name,Node) -> - {lists:reverse(Name),lists:reverse(Node),Rest}; -parse_name_node([H|T],Name,Node) -> - parse_name_node(T,Name,[H|Node]); -parse_name_node([],Name,Node) -> - %% truncated - {lists:reverse(Name),lists:reverse(Node),[]}. +get_link(<<"#Port",_/binary>>=PortBin,#{links:=Links}=Acc) -> + PortStr = binary_to_list(PortBin), + Acc#{links=>[{PortStr,PortStr}|Links]}; +get_link(<<"<",_/binary>>=PidBin,#{links:=Links}=Acc) -> + PidStr = binary_to_list(PidBin), + Acc#{links=>[{PidStr,PidStr}|Links]}; +get_link(<<"{to,",Bin/binary>>,#{mons:=Monitors}=Acc) -> + Acc#{mons=>[parse_monitor(Bin)|Monitors]}; +get_link(<<"{from,",Bin/binary>>,#{mon_by:=MonitoredBy}=Acc) -> + Acc#{mon_by=>[parse_monitor(Bin)|MonitoredBy]}; +get_link(Unexpected,Acc) -> + io:format("WARNING: found unexpected data in link list:~n~ts~n",[Unexpected]), + Acc. + +parse_monitor(MonBin) -> + case binary:split(MonBin,[<<",">>,<<"{">>,<<"}">>],[global]) of + [PidBin,RefBin,<<>>] -> + PidStr = binary_to_list(PidBin), + RefStr = binary_to_list(RefBin), + {PidStr,PidStr++" ("++RefStr++")"}; + [<<>>,NameBin,NodeBin,<<>>,RefBin,<<>>] -> + %% Named process + NameStr = binary_to_list(NameBin), + NodeStr = binary_to_list(NodeBin), + PidStr = get_pid_from_name(NameStr,NodeStr), + RefStr = binary_to_list(RefBin), + {PidStr,"{"++NameStr++","++NodeStr++"} ("++RefStr++")"} + end. get_pid_from_name(Name,Node) -> case ets:lookup(cdv_reg_proc_table,cdv_dump_node_name) of @@ -1402,70 +1426,85 @@ maybe_other_node2(Channel) -> expand_memory(Fd,Pid,DumpVsn) -> - BinAddrAdj = get_bin_addr_adj(DumpVsn), + DecodeOpts = get_decode_opts(DumpVsn), put(fd,Fd), Dict0 = case get(?literals) of undefined -> - Literals = read_literals(Fd), + Literals = read_literals(Fd,DecodeOpts), put(?literals,Literals), put(fd,Fd), Literals; Literals -> Literals end, - Dict = read_heap(Fd,Pid,BinAddrAdj,Dict0), - Expanded = {read_stack_dump(Fd,Pid,BinAddrAdj,Dict), - read_messages(Fd,Pid,BinAddrAdj,Dict), - read_dictionary(Fd,Pid,BinAddrAdj,Dict)}, + Dict = read_heap(Fd,Pid,DecodeOpts,Dict0), + Expanded = {read_stack_dump(Fd,Pid,DecodeOpts,Dict), + read_messages(Fd,Pid,DecodeOpts,Dict), + read_dictionary(Fd,Pid,DecodeOpts,Dict)}, erase(fd), - Expanded. - -read_literals(Fd) -> + IncompleteWarning = + case erase(incomplete_heap) of + undefined -> + []; + true -> + ["WARNING: This process has an incomplete heap. " + "Some information might be missing."] + end, + {Expanded,IncompleteWarning}. + +read_literals(Fd,DecodeOpts) -> case lookup_index(?literals,[]) of [{_,Start}] -> [{_,Chars}] = ets:lookup(cdv_heap_file_chars,literals), init_progress("Reading literals",Chars), pos_bof(Fd,Start), - read_heap(0,gb_trees:empty()); + read_heap(DecodeOpts,gb_trees:empty()); [] -> gb_trees:empty() end. -%%%----------------------------------------------------------------- -%%% This is a workaround for a bug in dump versions prior to 0.3: -%%% Addresses were truncated to 32 bits. This could cause binaries to -%%% get the same address as heap terms in the dump. To work around it -%%% we always store binaries on very high addresses in the gb_tree. -get_bin_addr_adj(DumpVsn) when DumpVsn < [0,3] -> - 16#f bsl 64; -get_bin_addr_adj(_) -> - 0. +get_decode_opts(DumpVsn) -> + BinAddrAdj = if + DumpVsn < [0,3] -> + %% This is a workaround for a bug in dump + %% versions prior to 0.3: Addresses were + %% truncated to 32 bits. This could cause + %% binaries to get the same address as heap + %% terms in the dump. To work around it we + %% always store binaries on very high + %% addresses in the gb_tree. + 16#f bsl 64; + true -> + 0 + end, + Base64 = DumpVsn >= [0,5], + #dec_opts{bin_addr_adj=BinAddrAdj,base64=Base64}. %%% %%% Read top level section. %%% -read_stack_dump(Fd,Pid,BinAddrAdj,Dict) -> +read_stack_dump(Fd,Pid,DecodeOpts,Dict) -> case lookup_index(?proc_stack,Pid) of [{_,Start}] -> pos_bof(Fd,Start), - read_stack_dump1(Fd,BinAddrAdj,Dict,[]); + read_stack_dump1(Fd,DecodeOpts,Dict,[]); [] -> [] end. -read_stack_dump1(Fd,BinAddrAdj,Dict,Acc) -> +read_stack_dump1(Fd,DecodeOpts,Dict,Acc) -> %% This function is never called if the dump is truncated in {?proc_heap,Pid} case bytes(Fd) of "=" ++ _next_tag -> lists:reverse(Acc); Line -> - Stack = parse_top(Line,BinAddrAdj,Dict), - read_stack_dump1(Fd,BinAddrAdj,Dict,[Stack|Acc]) + Stack = parse_top(Line,DecodeOpts,Dict), + read_stack_dump1(Fd,DecodeOpts,Dict,[Stack|Acc]) end. -parse_top(Line0, BinAddrAdj, D) -> +parse_top(Line0, DecodeOpts, D) -> {Label,Line1} = get_label(Line0), - {Term,Line,D} = parse_term(Line1, BinAddrAdj, D), + {Term,Line,D} = parse_term(Line1, DecodeOpts, D), [] = skip_blanks(Line), {Label,Term}. @@ -1473,27 +1512,27 @@ parse_top(Line0, BinAddrAdj, D) -> %%% Read message queue. %%% -read_messages(Fd,Pid,BinAddrAdj,Dict) -> +read_messages(Fd,Pid,DecodeOpts,Dict) -> case lookup_index(?proc_messages,Pid) of [{_,Start}] -> pos_bof(Fd,Start), - read_messages1(Fd,BinAddrAdj,Dict,[]); + read_messages1(Fd,DecodeOpts,Dict,[]); [] -> [] end. -read_messages1(Fd,BinAddrAdj,Dict,Acc) -> +read_messages1(Fd,DecodeOpts,Dict,Acc) -> %% This function is never called if the dump is truncated in {?proc_heap,Pid} case bytes(Fd) of "=" ++ _next_tag -> lists:reverse(Acc); Line -> - Msg = parse_message(Line,BinAddrAdj,Dict), - read_messages1(Fd,BinAddrAdj,Dict,[Msg|Acc]) + Msg = parse_message(Line,DecodeOpts,Dict), + read_messages1(Fd,DecodeOpts,Dict,[Msg|Acc]) end. -parse_message(Line0, BinAddrAdj, D) -> - {Msg,":"++Line1,_} = parse_term(Line0, BinAddrAdj, D), - {Token,Line,_} = parse_term(Line1, BinAddrAdj, D), +parse_message(Line0, DecodeOpts, D) -> + {Msg,":"++Line1,_} = parse_term(Line0, DecodeOpts, D), + {Token,Line,_} = parse_term(Line1, DecodeOpts, D), [] = skip_blanks(Line), {Msg,Token}. @@ -1501,26 +1540,26 @@ parse_message(Line0, BinAddrAdj, D) -> %%% Read process dictionary %%% -read_dictionary(Fd,Pid,BinAddrAdj,Dict) -> +read_dictionary(Fd,Pid,DecodeOpts,Dict) -> case lookup_index(?proc_dictionary,Pid) of [{_,Start}] -> pos_bof(Fd,Start), - read_dictionary1(Fd,BinAddrAdj,Dict,[]); + read_dictionary1(Fd,DecodeOpts,Dict,[]); [] -> [] end. -read_dictionary1(Fd,BinAddrAdj,Dict,Acc) -> +read_dictionary1(Fd,DecodeOpts,Dict,Acc) -> %% This function is never called if the dump is truncated in {?proc_heap,Pid} case bytes(Fd) of "=" ++ _next_tag -> lists:reverse(Acc); Line -> - Msg = parse_dictionary(Line,BinAddrAdj,Dict), - read_dictionary1(Fd,BinAddrAdj,Dict,[Msg|Acc]) + Msg = parse_dictionary(Line,DecodeOpts,Dict), + read_dictionary1(Fd,DecodeOpts,Dict,[Msg|Acc]) end. -parse_dictionary(Line0, BinAddrAdj, D) -> - {Entry,Line,_} = parse_term(Line0, BinAddrAdj, D), +parse_dictionary(Line0, DecodeOpts, D) -> + {Entry,Line,_} = parse_term(Line0, DecodeOpts, D), [] = skip_blanks(Line), Entry. @@ -1528,18 +1567,18 @@ parse_dictionary(Line0, BinAddrAdj, D) -> %%% Read heap data. %%% -read_heap(Fd,Pid,BinAddrAdj,Dict0) -> +read_heap(Fd,Pid,DecodeOpts,Dict0) -> case lookup_index(?proc_heap,Pid) of [{_,Pos}] -> [{_,Chars}] = ets:lookup(cdv_heap_file_chars,Pid), init_progress("Reading process heap",Chars), pos_bof(Fd,Pos), - read_heap(BinAddrAdj,Dict0); + read_heap(DecodeOpts,Dict0); [] -> Dict0 end. -read_heap(BinAddrAdj,Dict0) -> +read_heap(DecodeOpts,Dict0) -> %% This function is never called if the dump is truncated in {?proc_heap,Pid} case get(fd) of end_of_heap -> @@ -1553,14 +1592,14 @@ read_heap(BinAddrAdj,Dict0) -> Dict0; Line -> update_progress(length(Line)+1), - Dict = parse(Line,BinAddrAdj,Dict0), - read_heap(BinAddrAdj,Dict) + Dict = parse(Line,DecodeOpts,Dict0), + read_heap(DecodeOpts,Dict) end end. -parse(Line0, BinAddrAdj, Dict0) -> +parse(Line0, DecodeOpts, Dict0) -> {Addr,":"++Line1} = get_hex(Line0), - {_Term,Line,Dict} = parse_heap_term(Line1, Addr, BinAddrAdj, Dict0), + {_Term,Line,Dict} = parse_heap_term(Line1, Addr, DecodeOpts, Dict0), [] = skip_blanks(Line), Dict. @@ -1882,12 +1921,15 @@ get_nodeinfo(Fd,Nod) -> %%----------------------------------------------------------------- %% Page with details about one loaded modules -get_loaded_mod_details(File,Mod) -> +get_loaded_mod_details(File,Mod,DecodeOpts) -> [{_,Start}] = lookup_index(?mod,Mod), Fd = open(File), pos_bof(Fd,Start), InitLM = #loaded_mod{mod=Mod,old_size="No old code exists"}, - ModInfo = get_loaded_mod_info(Fd,InitLM,fun all_modinfo/3), + Fun = fun(F, LM, LineHead) -> + all_modinfo(F, LM, LineHead, DecodeOpts) + end, + ModInfo = get_loaded_mod_info(Fd,InitLM,Fun), close(Fd), ModInfo. @@ -1945,59 +1987,48 @@ get_loaded_mod_info(Fd,LM,Fun) -> main_modinfo(_Fd,LM,_LineHead) -> LM. -all_modinfo(Fd,LM,LineHead) -> +all_modinfo(Fd,LM,LineHead,DecodeOpts) -> case LineHead of "Current attributes" -> - Str = hex_to_str(bytes(Fd,"")), + Str = get_attribute(Fd, DecodeOpts), LM#loaded_mod{current_attrib=Str}; "Current compilation info" -> - Str = hex_to_str(bytes(Fd,"")), + Str = get_attribute(Fd, DecodeOpts), LM#loaded_mod{current_comp_info=Str}; "Old attributes" -> - Str = hex_to_str(bytes(Fd,"")), + Str = get_attribute(Fd, DecodeOpts), LM#loaded_mod{old_attrib=Str}; "Old compilation info" -> - Str = hex_to_str(bytes(Fd,"")), + Str = get_attribute(Fd, DecodeOpts), LM#loaded_mod{old_comp_info=Str}; Other -> unexpected(Fd,Other,"loaded modules info"), LM end. - -hex_to_str(Hex) -> - Term = hex_to_term(Hex,[]), +get_attribute(Fd, DecodeOpts) -> + Term = do_get_attribute(Fd, DecodeOpts), io_lib:format("~tp~n",[Term]). -hex_to_term([X,Y|Hex],Acc) -> - MS = hex_to_dec([X]), - LS = hex_to_dec([Y]), - Z = 16*MS+LS, - hex_to_term(Hex,[Z|Acc]); -hex_to_term([],Acc) -> - Bin = list_to_binary(lists:reverse(Acc)), - case catch binary_to_term(Bin) of - {'EXIT',_Reason} -> - {"WARNING: The term is probably truncated!", - "I can not do binary_to_term.", - Bin}; - Term -> - Term - end; -hex_to_term(Rest,Acc) -> - {"WARNING: The term is probably truncated!", - "I can not convert hex to term.", - Rest,list_to_binary(lists:reverse(Acc))}. - - -hex_to_dec("F") -> 15; -hex_to_dec("E") -> 14; -hex_to_dec("D") -> 13; -hex_to_dec("C") -> 12; -hex_to_dec("B") -> 11; -hex_to_dec("A") -> 10; -hex_to_dec(N) -> list_to_integer(N). - +do_get_attribute(Fd, DecodeOpts) -> + Bytes = bytes(Fd, ""), + try get_binary(Bytes, DecodeOpts) of + {Bin,_} -> + try binary_to_term(Bin) of + Term -> + Term + catch + _:_ -> + {"WARNING: The term is probably truncated!", + "I cannot do binary_to_term/1.", + Bin} + end + catch + _:_ -> + {"WARNING: The term is probably truncated!", + "I cannot convert to binary.", + Bytes} + end. %%----------------------------------------------------------------- %% Page with list of all funs @@ -2554,112 +2585,110 @@ get_limited_stack(Fd, N, Ds) -> %%%----------------------------------------------------------------- %%% Parse memory in crashdump version 0.1 and newer %%% -parse_heap_term([$l|Line0], Addr, BinAddrAdj, D0) -> %Cons cell. - {H,"|"++Line1,D1} = parse_term(Line0, BinAddrAdj, D0), - {T,Line,D2} = parse_term(Line1, BinAddrAdj, D1), +parse_heap_term([$l|Line0], Addr, DecodeOpts, D0) -> %Cons cell. + {H,"|"++Line1,D1} = parse_term(Line0, DecodeOpts, D0), + {T,Line,D2} = parse_term(Line1, DecodeOpts, D1), Term = [H|T], D = gb_trees:insert(Addr, Term, D2), {Term,Line,D}; -parse_heap_term([$t|Line0], Addr, BinAddrAdj, D) -> %Tuple +parse_heap_term([$t|Line0], Addr, DecodeOpts, D) -> %Tuple {N,":"++Line} = get_hex(Line0), - parse_tuple(N, Line, Addr, BinAddrAdj, D, []); -parse_heap_term([$F|Line0], Addr, _BinAddrAdj, D0) -> %Float + parse_tuple(N, Line, Addr, DecodeOpts, D, []); +parse_heap_term([$F|Line0], Addr, _DecodeOpts, D0) -> %Float {N,":"++Line1} = get_hex(Line0), {Chars,Line} = get_chars(N, Line1), Term = list_to_float(Chars), D = gb_trees:insert(Addr, Term, D0), {Term,Line,D}; -parse_heap_term("B16#"++Line0, Addr, _BinAddrAdj, D0) -> %Positive big number. +parse_heap_term("B16#"++Line0, Addr, _DecodeOpts, D0) -> %Positive big number. {Term,Line} = get_hex(Line0), D = gb_trees:insert(Addr, Term, D0), {Term,Line,D}; -parse_heap_term("B-16#"++Line0, Addr, _BinAddrAdj, D0) -> %Negative big number +parse_heap_term("B-16#"++Line0, Addr, _DecodeOpts, D0) -> %Negative big number {Term0,Line} = get_hex(Line0), Term = -Term0, D = gb_trees:insert(Addr, Term, D0), {Term,Line,D}; -parse_heap_term("B"++Line0, Addr, _BinAddrAdj, D0) -> %Decimal big num +parse_heap_term("B"++Line0, Addr, _DecodeOpts, D0) -> %Decimal big num case string:to_integer(Line0) of {Int,Line} when is_integer(Int) -> D = gb_trees:insert(Addr, Int, D0), {Int,Line,D} end; -parse_heap_term([$P|Line0], Addr, _BinAddrAdj, D0) -> % External Pid. +parse_heap_term([$P|Line0], Addr, _DecodeOpts, D0) -> % External Pid. {Pid0,Line} = get_id(Line0), Pid = ['#CDVPid'|Pid0], D = gb_trees:insert(Addr, Pid, D0), {Pid,Line,D}; -parse_heap_term([$p|Line0], Addr, _BinAddrAdj, D0) -> % External Port. +parse_heap_term([$p|Line0], Addr, _DecodeOpts, D0) -> % External Port. {Port0,Line} = get_id(Line0), Port = ['#CDVPort'|Port0], D = gb_trees:insert(Addr, Port, D0), {Port,Line,D}; -parse_heap_term("E"++Line0, Addr, _BinAddrAdj, D0) -> %Term encoded in external format. - {Bin,Line} = get_binary(Line0), +parse_heap_term("E"++Line0, Addr, DecodeOpts, D0) -> %Term encoded in external format. + {Bin,Line} = get_binary(Line0, DecodeOpts), Term = binary_to_term(Bin), D = gb_trees:insert(Addr, Term, D0), {Term,Line,D}; -parse_heap_term("Yh"++Line0, Addr, _BinAddrAdj, D0) -> %Heap binary. - {Term,Line} = get_binary(Line0), +parse_heap_term("Yh"++Line0, Addr, DecodeOpts, D0) -> %Heap binary. + {Term,Line} = get_binary(Line0, DecodeOpts), D = gb_trees:insert(Addr, Term, D0), {Term,Line,D}; -parse_heap_term("Yc"++Line0, Addr, BinAddrAdj, D0) -> %Reference-counted binary. +parse_heap_term("Yc"++Line0, Addr, DecodeOpts, D0) -> %Reference-counted binary. {Binp0,":"++Line1} = get_hex(Line0), {Offset,":"++Line2} = get_hex(Line1), {Sz,Line} = get_hex(Line2), - Binp = Binp0 bor BinAddrAdj, - Term = case lookup_binary_index(Binp) of - [{_,Start}] -> cdvbin(Offset,Sz,{'#CDVBin',Start}); - [] -> '#CDVNonexistingBinary' - end, - D = gb_trees:insert(Addr, Term, D0), - {Term,Line,D}; -parse_heap_term("Ys"++Line0, Addr, BinAddrAdj, D0) -> %Sub binary. + Binp = Binp0 bor DecodeOpts#dec_opts.bin_addr_adj, + case lookup_binary_index(Binp) of + [{_,Start}] -> + SymbolicBin = {'#CDVBin',Start}, + Term = cdvbin(Offset, Sz, SymbolicBin), + D1 = gb_trees:insert(Addr, Term, D0), + D = gb_trees:insert(Binp, SymbolicBin, D1), + {Term,Line,D}; + [] -> + Term = '#CDVNonexistingBinary', + D1 = gb_trees:insert(Addr, Term, D0), + D = gb_trees:insert(Binp, Term, D1), + {Term,Line,D} + end; +parse_heap_term("Ys"++Line0, Addr, DecodeOpts, D0) -> %Sub binary. {Binp0,":"++Line1} = get_hex(Line0), {Offset,":"++Line2} = get_hex(Line1), - {Sz,Line} = get_hex(Line2), - Binp = Binp0 bor BinAddrAdj, - Term = case lookup_binary_index(Binp) of - [{_,Start}] -> cdvbin(Offset,Sz,{'#CDVBin',Start}); - [] -> - %% Might it be on the heap? - case gb_trees:lookup(Binp, D0) of - {value,Bin} -> cdvbin(Offset,Sz,Bin); - none -> '#CDVNonexistingBinary' - end - end, - D = gb_trees:insert(Addr, Term, D0), + {Sz,Line3} = get_hex(Line2), + {Term,Line,D1} = deref_bin(Binp0, Offset, Sz, Line3, DecodeOpts, D0), + D = gb_trees:insert(Addr, Term, D1), {Term,Line,D}; -parse_heap_term("Mf"++Line0, Addr, BinAddrAdj, D0) -> %Flatmap. +parse_heap_term("Mf"++Line0, Addr, DecodeOpts, D0) -> %Flatmap. {Size,":"++Line1} = get_hex(Line0), - {Keys,":"++Line2,D1} = parse_term(Line1, BinAddrAdj, D0), - {Values,Line,D2} = parse_tuple(Size, Line2, Addr,BinAddrAdj, D1, []), + {Keys,":"++Line2,D1} = parse_term(Line1, DecodeOpts, D0), + {Values,Line,D2} = parse_tuple(Size, Line2, Addr,DecodeOpts, D1, []), Pairs = zip_tuples(tuple_size(Keys), Keys, Values, []), Map = maps:from_list(Pairs), D = gb_trees:update(Addr, Map, D2), {Map,Line,D}; -parse_heap_term("Mh"++Line0, Addr, BinAddrAdj, D0) -> %Head node in a hashmap. +parse_heap_term("Mh"++Line0, Addr, DecodeOpts, D0) -> %Head node in a hashmap. {MapSize,":"++Line1} = get_hex(Line0), {N,":"++Line2} = get_hex(Line1), - {Nodes,Line,D1} = parse_tuple(N, Line2, Addr, BinAddrAdj, D0, []), + {Nodes,Line,D1} = parse_tuple(N, Line2, Addr, DecodeOpts, D0, []), Map = maps:from_list(flatten_hashmap_nodes(Nodes)), MapSize = maps:size(Map), %Assertion. D = gb_trees:update(Addr, Map, D1), {Map,Line,D}; -parse_heap_term("Mn"++Line0, Addr, BinAddrAdj, D) -> %Interior node in a hashmap. +parse_heap_term("Mn"++Line0, Addr, DecodeOpts, D) -> %Interior node in a hashmap. {N,":"++Line} = get_hex(Line0), - parse_tuple(N, Line, Addr, BinAddrAdj, D, []). + parse_tuple(N, Line, Addr, DecodeOpts, D, []). parse_tuple(0, Line, Addr, _, D0, Acc) -> Tuple = list_to_tuple(lists:reverse(Acc)), D = gb_trees:insert(Addr, Tuple, D0), {Tuple,Line,D}; -parse_tuple(N, Line0, Addr, BinAddrAdj, D0, Acc) -> - case parse_term(Line0, BinAddrAdj, D0) of +parse_tuple(N, Line0, Addr, DecodeOpts, D0, Acc) -> + case parse_term(Line0, DecodeOpts, D0) of {Term,[$,|Line],D} when N > 1 -> - parse_tuple(N-1, Line, Addr, BinAddrAdj, D, [Term|Acc]); + parse_tuple(N-1, Line, Addr, DecodeOpts, D, [Term|Acc]); {Term,Line,D}-> - parse_tuple(N-1, Line, Addr, BinAddrAdj, D, [Term|Acc]) + parse_tuple(N-1, Line, Addr, DecodeOpts, D, [Term|Acc]) end. zip_tuples(0, _T1, _T2, Acc) -> @@ -2681,9 +2710,9 @@ flatten_hashmap_nodes_1(N, Tuple0, Acc0) -> flatten_hashmap_nodes_1(tuple_size(Tuple), Tuple, Acc) end. -parse_term([$H|Line0], BinAddrAdj, D) -> %Pointer to heap term. +parse_term([$H|Line0], DecodeOpts, D) -> %Pointer to heap term. {Ptr,Line} = get_hex(Line0), - deref_ptr(Ptr, Line, BinAddrAdj, D); + deref_ptr(Ptr, Line, DecodeOpts, D); parse_term([$N|Line], _, D) -> %[] (nil). {[],Line,D}; parse_term([$I|Line0], _, D) -> %Small. @@ -2700,11 +2729,11 @@ parse_term([$p|Line0], _, D) -> %Port. parse_term([$S|Str0], _, D) -> %Information string. Str = lists:reverse(skip_blanks(lists:reverse(Str0))), {Str,[],D}; -parse_term([$D|Line0], _, D) -> %DistExternal +parse_term([$D|Line0], DecodeOpts, D) -> %DistExternal try {AttabSize,":"++Line1} = get_hex(Line0), {Attab, "E"++Line2} = parse_atom_translation_table(AttabSize, Line1, []), - {Bin,Line3} = get_binary(Line2), + {Bin,Line3} = get_binary(Line2, DecodeOpts), {try erts_debug:dist_ext_to_term(Attab, Bin) catch @@ -2737,26 +2766,55 @@ parse_atom_translation_table(0, Line0, As) -> parse_atom_translation_table(N, Line0, As) -> {A, Line1, _} = parse_atom(Line0, []), parse_atom_translation_table(N-1, Line1, [A|As]). - - -deref_ptr(Ptr, Line, BinAddrAdj, D0) -> - case gb_trees:lookup(Ptr, D0) of + +deref_ptr(Ptr, Line, DecodeOpts, D) -> + Lookup = fun(D0) -> + gb_trees:lookup(Ptr, D0) + end, + do_deref_ptr(Lookup, Line, DecodeOpts, D). + +deref_bin(Binp0, Offset, Sz, Line, DecodeOpts, D) -> + Binp = Binp0 bor DecodeOpts#dec_opts.bin_addr_adj, + Lookup = fun(D0) -> + lookup_binary(Binp, Offset, Sz, D0) + end, + do_deref_ptr(Lookup, Line, DecodeOpts, D). + +lookup_binary(Binp, Offset, Sz, D) -> + case lookup_binary_index(Binp) of + [{_,Start}] -> + Term = cdvbin(Offset, Sz, {'#CDVBin',Start}), + {value,Term}; + [] -> + case gb_trees:lookup(Binp, D) of + {value,<<_:Offset/bytes,Sub:Sz/bytes,_/bytes>>} -> + {value,Sub}; + {value,SymbolicBin} -> + {value,cdvbin(Offset, Sz, SymbolicBin)}; + none -> + none + end + end. + +do_deref_ptr(Lookup, Line, DecodeOpts, D0) -> + case Lookup(D0) of {value,Term} -> {Term,Line,D0}; none -> case get(fd) of end_of_heap -> + put(incomplete_heap,true), {['#CDVIncompleteHeap'],Line,D0}; Fd -> case bytes(Fd) of "="++_ -> put(fd, end_of_heap), - deref_ptr(Ptr, Line, BinAddrAdj, D0); + do_deref_ptr(Lookup, Line, DecodeOpts, D0); L -> update_progress(length(L)+1), - D = parse(L, BinAddrAdj, D0), - deref_ptr(Ptr, Line, BinAddrAdj, D) + D = parse(L, DecodeOpts, D0), + do_deref_ptr(Lookup, Line, DecodeOpts, D) end end end. @@ -2819,36 +2877,80 @@ get_label([$:|Line], Acc) -> get_label([H|T], Acc) -> get_label(T, [H|Acc]). -get_binary(Line0) -> +get_binary(Line0,DecodeOpts) -> case get_hex(Line0) of {N,":"++Line} -> - do_get_binary(N, Line, [], false); + get_binary_1(N, Line, DecodeOpts); _ -> {'#CDVTruncatedBinary',[]} end. -get_binary(Offset,Size,Line0) -> +get_binary_1(N,Line,#dec_opts{base64=false}) -> + get_binary_hex(N, Line, [], false); +get_binary_1(N,Line0,#dec_opts{base64=true}) -> + NumBytes = ((N+2) div 3) * 4, + {Base64,Line} = lists:split(NumBytes, Line0), + Bin = get_binary_base64(list_to_binary(Base64), <<>>, false), + {Bin,Line}. + +get_binary(Offset,Size,Line0,DecodeOpts) -> case get_hex(Line0) of {_N,":"++Line} -> - Progress = Size>?binary_size_progress_limit, - Progress andalso init_progress("Reading binary",Size), - do_get_binary(Size, lists:sublist(Line,(Offset*2)+1,Size*2), [], - Progress); - _ -> - {'#CDVTruncatedBinary',[]} - end. - -do_get_binary(0, Line, Acc, Progress) -> + get_binary_1(Offset,Size,Line,DecodeOpts); + _ -> + {'#CDVTruncatedBinary',[]} + end. + +get_binary_1(Offset,Size,Line,#dec_opts{base64=false}) -> + Progress = Size > ?binary_size_progress_limit, + Progress andalso init_progress("Reading binary",Size), + get_binary_hex(Size, lists:sublist(Line,(Offset*2)+1,Size*2), [], + Progress); +get_binary_1(StartOffset,Size,Line,#dec_opts{base64=true}) -> + Progress = Size > ?binary_size_progress_limit, + Progress andalso init_progress("Reading binary",Size), + EndOffset = StartOffset + Size, + StartByte = (StartOffset div 3) * 4, + EndByte = ((EndOffset + 2) div 3) * 4, + NumBytes = EndByte - StartByte, + case list_to_binary(Line) of + <<_:StartByte/bytes,Base64:NumBytes/bytes,_/bytes>> -> + Bin0 = get_binary_base64(Base64, <<>>, Progress), + Skip = StartOffset - (StartOffset div 3) * 3, + <<_:Skip/bytes,Bin:Size/bytes,_/bytes>> = Bin0, + {Bin,[]}; + _ -> + {'#CDVTruncatedBinary',[]} + end. + +get_binary_hex(0, Line, Acc, Progress) -> Progress andalso end_progress(), {list_to_binary(lists:reverse(Acc)),Line}; -do_get_binary(N, [A,B|Line], Acc, Progress) -> +get_binary_hex(N, [A,B|Line], Acc, Progress) -> Byte = (get_hex_digit(A) bsl 4) bor get_hex_digit(B), Progress andalso update_progress(), - do_get_binary(N-1, Line, [Byte|Acc], Progress); -do_get_binary(_N, [], _Acc, Progress) -> + get_binary_hex(N-1, Line, [Byte|Acc], Progress); +get_binary_hex(_N, [], _Acc, Progress) -> Progress andalso end_progress(), {'#CDVTruncatedBinary',[]}. +get_binary_base64(<<Chunk0:?base64_chunk_size/bytes,T/bytes>>, + Acc0, Progress) -> + Chunk = base64:decode(Chunk0), + Acc = <<Acc0/binary,Chunk/binary>>, + Progress andalso update_progress(?base64_chunk_size * 3 div 4), + get_binary_base64(T, Acc, Progress); +get_binary_base64(Chunk0, Acc, Progress) -> + case Progress of + true -> + update_progress(?base64_chunk_size * 3 div 4), + end_progress(); + false -> + ok + end, + Chunk = base64:decode(Chunk0), + <<Acc/binary,Chunk/binary>>. + cdvbin(Offset,Size,{'#CDVBin',Pos}) -> ['#CDVBin',Offset,Size,Pos]; cdvbin(Offset,Size,['#CDVBin',_,_,Pos]) -> diff --git a/lib/observer/src/observer_html_lib.erl b/lib/observer/src/observer_html_lib.erl index 68381bcc7b..8202f91030 100644 --- a/lib/observer/src/observer_html_lib.erl +++ b/lib/observer/src/observer_html_lib.erl @@ -355,11 +355,11 @@ href_proc_bin(From, T, Acc, LTB) -> PreviewStr end end; - [PreviewIntStr,SizeStr,Md5] when From =:= obs -> + [PreviewIntStr,PreviewBitSizeStr,SizeStr,Md5] when From =:= obs -> Size = list_to_integer(SizeStr), PreviewInt = list_to_integer(PreviewIntStr), - PrevSize = (trunc(math:log2(PreviewInt)/8)+1)*8, - PreviewStr = preview_string(Size,<<PreviewInt:PrevSize>>), + PreviewBitSize = list_to_integer(PreviewBitSizeStr), + PreviewStr = preview_string(Size,<<PreviewInt:PreviewBitSize>>), if LTB -> href("TARGET=\"expanded\"", ["#OBSBinary?key1="++PreviewIntStr++ diff --git a/lib/observer/src/observer_lib.erl b/lib/observer/src/observer_lib.erl index e5ffe61d25..0678b64134 100644 --- a/lib/observer/src/observer_lib.erl +++ b/lib/observer/src/observer_lib.erl @@ -21,7 +21,8 @@ -export([get_wx_parent/1, display_info_dialog/2, display_yes_no_dialog/1, - display_progress_dialog/3, destroy_progress_dialog/0, + display_progress_dialog/3, + destroy_progress_dialog/0, sync_destroy_progress_dialog/0, wait_for_progress/0, report_progress/1, user_term/3, user_term_multiline/3, interval_dialog/4, start_timer/1, start_timer/2, stop_timer/1, timer_config/1, @@ -31,7 +32,8 @@ set_listctrl_col_size/2, create_status_bar/1, html_window/1, html_window/2, - make_obsbin/2 + make_obsbin/2, + add_scroll_entries/2 ]). -include_lib("wx/include/wx.hrl"). @@ -40,6 +42,8 @@ -define(SINGLE_LINE_STYLE, ?wxBORDER_NONE bor ?wxTE_READONLY bor ?wxTE_RICH2). -define(MULTI_LINE_STYLE, ?SINGLE_LINE_STYLE bor ?wxTE_MULTILINE). +-define(NUM_SCROLL_ITEMS,8). + -define(pulse_timeout,50). get_wx_parent(Window) -> @@ -397,17 +401,18 @@ get_box_info({Title, left, List}) -> {Title, ?wxALIGN_LEFT, List}; get_box_info({Title, right, List}) -> {Title, ?wxALIGN_RIGHT, List}. add_box(Panel, OuterBox, Cursor, Title, Proportion, {Format, List}) -> - Box = wxStaticBoxSizer:new(?wxVERTICAL, Panel, [{label, Title}]), + NumStr = " ("++integer_to_list(length(List))++")", + Box = wxStaticBoxSizer:new(?wxVERTICAL, Panel, [{label, Title ++ NumStr}]), Scroll = wxScrolledWindow:new(Panel), wxScrolledWindow:enableScrolling(Scroll,true,true), wxScrolledWindow:setScrollbars(Scroll,1,1,0,0), ScrollSizer = wxBoxSizer:new(?wxVERTICAL), wxScrolledWindow:setSizer(Scroll, ScrollSizer), wxWindow:setBackgroundStyle(Scroll, ?wxBG_STYLE_SYSTEM), - add_entries(Format, List, Scroll, ScrollSizer, Cursor), + Entries = 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)}. + {Scroll,ScrollSizer,length(Entries)}. add_entries(click, List, Scroll, ScrollSizer, Cursor) -> Add = fun(Link) -> @@ -415,7 +420,20 @@ add_entries(click, List, Scroll, ScrollSizer, Cursor) -> wxWindow:setBackgroundStyle(TC, ?wxBG_STYLE_SYSTEM), wxSizer:add(ScrollSizer,TC, [{flag,?wxEXPAND}]) end, - [Add(Link) || Link <- List]; + if length(List) > ?NUM_SCROLL_ITEMS -> + {List1,Rest} = lists:split(?NUM_SCROLL_ITEMS,List), + LinkEntries = [Add(Link) || Link <- List1], + NStr = integer_to_list(length(Rest)), + TC = link_entry2(Scroll, + {{more,{Rest,Scroll,ScrollSizer}},"more..."}, + Cursor, + "Click to see " ++ NStr ++ " more entries"), + wxWindow:setBackgroundStyle(TC, ?wxBG_STYLE_SYSTEM), + E = wxSizer:add(ScrollSizer,TC, [{flag,?wxEXPAND}]), + LinkEntries ++ [E]; + true -> + [Add(Link) || Link <- List] + end; add_entries(plain, List, Scroll, ScrollSizer, _) -> Add = fun(String) -> TC = wxStaticText:new(Scroll, ?wxID_ANY, String), @@ -423,6 +441,23 @@ add_entries(plain, List, Scroll, ScrollSizer, _) -> end, [Add(String) || String <- List]. +add_scroll_entries(MoreEntry,{List, Scroll, ScrollSizer}) -> + wx:batch( + fun() -> + wxSizer:remove(ScrollSizer,?NUM_SCROLL_ITEMS), + wxStaticText:destroy(MoreEntry), + Cursor = wxCursor:new(?wxCURSOR_HAND), + Add = fun(Link) -> + TC = link_entry(Scroll, Link, Cursor), + wxWindow:setBackgroundStyle(TC, ?wxBG_STYLE_SYSTEM), + wxSizer:add(ScrollSizer,TC, [{flag,?wxEXPAND}]) + end, + Entries = [Add(Link) || Link <- List], + wxCursor:destroy(Cursor), + wxSizer:layout(ScrollSizer), + wxSizer:setVirtualSizeHints(ScrollSizer,Scroll), + Entries + end). create_box(_Panel, {scroll_boxes,[]}) -> undefined; @@ -449,7 +484,7 @@ create_box(Panel, {scroll_boxes,Data}) -> {_,H} = wxWindow:getSize(Dummy), wxTextCtrl:destroy(Dummy), - MaxH = if MaxL > 8 -> 8*H; + MaxH = if MaxL > ?NUM_SCROLL_ITEMS -> ?NUM_SCROLL_ITEMS*H; true -> MaxL*H end, [wxWindow:setMinSize(B,{0,MaxH}) || {B,_,_} <- Boxes], @@ -504,20 +539,22 @@ create_box(Parent, Data) -> link_entry(Panel, Link) -> Cursor = wxCursor:new(?wxCURSOR_HAND), - TC = link_entry2(Panel, to_link(Link), Cursor), + TC = link_entry(Panel, Link, Cursor), wxCursor:destroy(Cursor), TC. link_entry(Panel, Link, Cursor) -> - link_entry2(Panel, to_link(Link), Cursor). + link_entry2(Panel,to_link(Link),Cursor). link_entry2(Panel,{Target,Str},Cursor) -> + link_entry2(Panel,{Target,Str},Cursor,"Click to see properties for " ++ Str). +link_entry2(Panel,{Target,Str},Cursor,ToolTipText) -> TC = wxStaticText:new(Panel, ?wxID_ANY, Str), wxWindow:setForegroundColour(TC,?wxBLUE), wxWindow:setCursor(TC, Cursor), 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), + ToolTip = wxToolTip:new(ToolTipText), wxWindow:setToolTip(TC, ToolTip), TC. @@ -708,6 +745,11 @@ wait_for_progress() -> destroy_progress_dialog() -> report_progress(finish). +sync_destroy_progress_dialog() -> + Ref = erlang:monitor(process,?progress_handler), + destroy_progress_dialog(), + receive {'DOWN',Ref,process,_,_} -> ok end. + report_progress(Progress) -> case whereis(?progress_handler) of Pid when is_pid(Pid) -> @@ -787,9 +829,8 @@ progress_dialog_new(Parent,Title,Str) -> [{style,?wxDEFAULT_DIALOG_STYLE}]), Panel = wxPanel:new(Dialog), Sizer = wxBoxSizer:new(?wxVERTICAL), - Message = wxStaticText:new(Panel, 1, Str), - Gauge = wxGauge:new(Panel, 2, 100, [{size, {170, -1}}, - {style, ?wxGA_HORIZONTAL}]), + Message = wxStaticText:new(Panel, 1, Str,[{size,{220,-1}}]), + Gauge = wxGauge:new(Panel, 2, 100, [{style, ?wxGA_HORIZONTAL}]), SizerFlags = ?wxEXPAND bor ?wxLEFT bor ?wxRIGHT bor ?wxTOP, wxSizer:add(Sizer, Message, [{flag,SizerFlags},{border,15}]), wxSizer:add(Sizer, Gauge, [{flag, SizerFlags bor ?wxBOTTOM},{border,15}]), @@ -810,7 +851,7 @@ progress_dialog_destroy({Dialog,_,_}) -> make_obsbin(Bin,Tab) -> Size = byte_size(Bin), - Preview = + {Preview,PreviewBitSize} = try %% The binary might be a unicode string, in which case we %% don't want to split it in the middle of a grapheme @@ -819,14 +860,14 @@ make_obsbin(Bin,Tab) -> PB1 = string:slice(Bin,0,PL1), PS1 = byte_size(PB1) * 8, <<P1:PS1>> = PB1, - P1 + {P1,PS1} catch _:_ -> %% Probably not a string, so just split anywhere PS2 = min(Size, 10) * 8, <<P2:PS2, _/binary>> = Bin, - P2 + {P2,PS2} end, Hash = erlang:phash2(Bin), Key = {Preview, Size, Hash}, ets:insert(Tab, {Key,Bin}), - ['#OBSBin',Preview,Size,Hash]. + ['#OBSBin',Preview,PreviewBitSize,Size,Hash]. diff --git a/lib/observer/src/observer_port_wx.erl b/lib/observer/src/observer_port_wx.erl index 5908e99e36..f7ae07fb85 100644 --- a/lib/observer/src/observer_port_wx.erl +++ b/lib/observer/src/observer_port_wx.erl @@ -242,6 +242,10 @@ handle_event(#wx{id=?ID_REFRESH_INTERVAL}, Timer = observer_lib:interval_dialog(Grid, Timer0, 10, 5*60), {noreply, State#state{timer=Timer}}; +handle_event(#wx{obj=MoreEntry,event=#wxMouse{type=left_down},userData={more,More}}, State) -> + observer_lib:add_scroll_entries(MoreEntry,More), + {noreply, State}; + handle_event(#wx{event=#wxMouse{type=left_down}, userData=TargetPid}, State) -> observer ! {open_link, TargetPid}, {noreply, State}; diff --git a/lib/observer/src/observer_pro_wx.erl b/lib/observer/src/observer_pro_wx.erl index 2e5fe0bc1a..1c40afba46 100644 --- a/lib/observer/src/observer_pro_wx.erl +++ b/lib/observer/src/observer_pro_wx.erl @@ -27,7 +27,7 @@ handle_event/2, handle_cast/2]). -include_lib("wx/include/wx.hrl"). --include("../include/etop.hrl"). +-include("etop.hrl"). -include("observer_defs.hrl"). -include("etop_defs.hrl"). @@ -572,7 +572,8 @@ change_accum(true, S0) -> S0#holder{accum=true}; change_accum(false, S0=#holder{info=Info}) -> self() ! refresh, - S0#holder{accum=lists:sort(array:to_list(Info))}. + Accum = [{Pid, Reds} || #etop_proc_info{pid=Pid, reds=Reds} <- array:to_list(Info)], + S0#holder{accum=lists:sort(Accum)}. handle_update_old(#etop_info{procinfo=ProcInfo0}, S0=#holder{parent=Parent, sort=Sort=#sort{sort_key=KeyField}}) -> diff --git a/lib/observer/src/observer_procinfo.erl b/lib/observer/src/observer_procinfo.erl index 4ce38e439d..6b761cb2ff 100644 --- a/lib/observer/src/observer_procinfo.erl +++ b/lib/observer/src/observer_procinfo.erl @@ -120,6 +120,10 @@ handle_event(#wx{id=?REFRESH}, #state{frame=Frame, pid=Pid, pages=Pages, expand_ end, {noreply, State}; +handle_event(#wx{obj=MoreEntry,event=#wxMouse{type=left_down},userData={more,More}}, State) -> + observer_lib:add_scroll_entries(MoreEntry,More), + {noreply, State}; + handle_event(#wx{event=#wxMouse{type=left_down}, userData=TargetPid}, State) -> observer ! {open_link, TargetPid}, {noreply, State}; @@ -253,8 +257,6 @@ init_stack_page(Parent, Pid) -> [Pid, current_stacktrace]) of {current_stacktrace,RawBt} -> - observer_wx:try_rpc(node(Pid), erlang, process_info, - [Pid, current_stacktrace]), wxListCtrl:deleteAllItems(LCtrl), wx:foldl(fun({M, F, A, Info}, Row) -> _Item = wxListCtrl:insertItem(LCtrl, Row, ""), diff --git a/lib/observer/src/observer_tv_wx.erl b/lib/observer/src/observer_tv_wx.erl index e16f3cab6b..2e387f7e74 100644 --- a/lib/observer/src/observer_tv_wx.erl +++ b/lib/observer/src/observer_tv_wx.erl @@ -38,13 +38,13 @@ -define(ID_SYSTEM_TABLES, 406). -define(ID_TABLE_INFO, 407). -define(ID_SHOW_TABLE, 408). - --record(opt, {type=ets, - sys_hidden=true, - unread_hidden=true, - sort_key=2, - sort_incr=true - }). + +-record(opts, {type=ets, + sys_hidden=true, + unread_hidden=true}). + +-record(sort, {sort_incr=true, + sort_key=2}). -record(state, { @@ -52,9 +52,9 @@ grid, panel, node=node(), - opt=#opt{}, + opts=#opts{}, + holder, selected, - tabs, timer }). @@ -64,8 +64,18 @@ start_link(Notebook, Parent, Config) -> init([Notebook, Parent, Config]) -> Panel = wxPanel:new(Notebook), Sizer = wxBoxSizer:new(?wxVERTICAL), - Style = ?wxLC_REPORT bor ?wxLC_SINGLE_SEL bor ?wxLC_HRULES, - Grid = wxListCtrl:new(Panel, [{winid, ?GRID}, {style, Style}]), + + Opts=#opts{type=maps:get(type, Config, ets), + sys_hidden=maps:get(sys_hidden, Config, true), + unread_hidden=maps:get(unread_hidden, Config, true)}, + + Style = ?wxLC_REPORT bor ?wxLC_VIRTUAL bor ?wxLC_SINGLE_SEL bor ?wxLC_HRULES, + Self = self(), + Attrs = observer_lib:create_attrs(), + Holder = spawn_link(fun() -> init_table_holder(Self, Attrs) end), + CBs = [{onGetItemText, fun(_, Item,Col) -> get_row(Holder, Item, Col) end}, + {onGetItemAttr, fun(_, Item) -> get_attr(Holder, Item) end}], + Grid = wxListCtrl:new(Panel, [{winid, ?GRID}, {style, Style} | CBs]), wxSizer:add(Sizer, Grid, [{flag, ?wxEXPAND bor ?wxALL}, {proportion, 1}, {border, 5}]), wxWindow:setSizer(Panel, Sizer), @@ -95,38 +105,26 @@ init([Notebook, Parent, Config]) -> wxWindow:setFocus(Grid), {Panel, #state{grid=Grid, parent=Parent, panel=Panel, - timer=Config, - opt=#opt{type=maps:get(type, Config, ets), - sys_hidden=maps:get(sys_hidden, Config, true), - unread_hidden=maps:get(unread_hidden, Config, true)} - }}. + opts=Opts, timer=Config, holder=Holder}}. handle_event(#wx{id=?ID_REFRESH}, - State = #state{node=Node, grid=Grid, opt=Opt}) -> - Tables = get_tables(Node, Opt), - {Tabs,Sel} = update_grid(Grid, sel(State), Opt, Tables), - Sel =/= undefined andalso wxListCtrl:ensureVisible(Grid, Sel), - {noreply, State#state{tabs=Tabs, selected=Sel}}; + State = #state{holder=Holder, node=Node, opts=Opts}) -> + Tables = get_tables(Node, Opts), + Holder ! {refresh, Tables}, + {noreply, State}; handle_event(#wx{event=#wxList{type=command_list_col_click, col=Col}}, - State = #state{node=Node, grid=Grid, - opt=Opt0=#opt{sort_key=Key, sort_incr=Bool}}) -> - Opt = case col2key(Col) of - Key -> Opt0#opt{sort_incr=not Bool}; - NewKey -> Opt0#opt{sort_key=NewKey} - end, - Tables = get_tables(Node, Opt), - {Tabs,Sel} = update_grid(Grid, sel(State), Opt, Tables), - wxWindow:setFocus(Grid), - {noreply, State#state{opt=Opt, tabs=Tabs, selected=Sel}}; + State = #state{holder=Holder}) -> + Holder ! {sort, Col}, + {noreply, State}; -handle_event(#wx{id=Id}, State = #state{node=Node, grid=Grid, opt=Opt0}) +handle_event(#wx{id=Id}, State = #state{node=Node, holder=Holder, grid=Grid, opts=Opt0}) when Id >= ?ID_ETS, Id =< ?ID_SYSTEM_TABLES -> Opt = case Id of - ?ID_ETS -> Opt0#opt{type=ets}; - ?ID_MNESIA -> Opt0#opt{type=mnesia}; - ?ID_UNREADABLE -> Opt0#opt{unread_hidden= not Opt0#opt.unread_hidden}; - ?ID_SYSTEM_TABLES -> Opt0#opt{sys_hidden= not Opt0#opt.sys_hidden} + ?ID_ETS -> Opt0#opts{type=ets}; + ?ID_MNESIA -> Opt0#opts{type=mnesia}; + ?ID_UNREADABLE -> Opt0#opts{unread_hidden= not Opt0#opts.unread_hidden}; + ?ID_SYSTEM_TABLES -> Opt0#opts{sys_hidden= not Opt0#opts.sys_hidden} end, case get_tables2(Node, Opt) of Error = {error, _} -> @@ -135,9 +133,9 @@ handle_event(#wx{id=Id}, State = #state{node=Node, grid=Grid, opt=Opt0}) self() ! Error, {noreply, State}; Tables -> - {Tabs, Sel} = update_grid(Grid, sel(State), Opt, Tables), + Holder ! {refresh, Tables}, wxWindow:setFocus(Grid), - {noreply, State#state{opt=Opt, tabs=Tabs, selected=Sel}} + {noreply, State#state{opts=Opt}} end; handle_event(#wx{event=#wxSize{size={W,_}}}, State=#state{grid=Grid}) -> @@ -146,19 +144,18 @@ handle_event(#wx{event=#wxSize{size={W,_}}}, State=#state{grid=Grid}) -> handle_event(#wx{event=#wxList{type=command_list_item_activated, itemIndex=Index}}, - State=#state{grid=Grid, node=Node, opt=#opt{type=Type}, tabs=Tabs}) -> - Table = lists:nth(Index+1, Tabs), - case Table#tab.protection of - private -> - self() ! {error, "Table has 'private' protection and can not be read"}; - _ -> - observer_tv_table:start_link(Grid, [{node,Node}, {type,Type}, {table,Table}]) + State=#state{holder=Holder, node=Node, opts=#opts{type=Type}, grid=Grid}) -> + case get_table(Holder, Index) of + #tab{protection=private} -> + self() ! {error, "Table has 'private' protection and can not be read"}; + #tab{}=Table -> + observer_tv_table:start_link(Grid, [{node,Node}, {type,Type}, {table,Table}]); + _ -> ignore end, {noreply, State}; handle_event(#wx{event=#wxList{type=command_list_item_right_click}}, State=#state{panel=Panel}) -> - Menu = wxMenu:new(), wxMenu:append(Menu, ?ID_TABLE_INFO, "Table info"), wxMenu:append(Menu, ?ID_SHOW_TABLE, "Show Table Content"), @@ -167,32 +164,33 @@ handle_event(#wx{event=#wxList{type=command_list_item_right_click}}, {noreply, State}; handle_event(#wx{event=#wxList{type=command_list_item_selected, itemIndex=Index}}, - State) -> + State=#state{holder=Holder}) -> + Holder ! {selected, Index}, {noreply, State#state{selected=Index}}; handle_event(#wx{id=?ID_TABLE_INFO}, - State = #state{grid=Grid, node=Node, opt=#opt{type=Type}, tabs=Tabs, selected=Sel}) -> + State = #state{holder=Holder, grid=Grid, node=Node, opts=#opts{type=Type}, selected=Sel}) -> case Sel of undefined -> {noreply, State}; R when is_integer(R) -> - Table = lists:nth(Sel+1, Tabs), + Table = get_table(Holder, Sel), display_table_info(Grid, Node, Type, Table), {noreply, State} end; handle_event(#wx{id=?ID_SHOW_TABLE}, - State=#state{grid=Grid, node=Node, opt=#opt{type=Type}, tabs=Tabs, selected=Sel}) -> + State=#state{holder=Holder, grid=Grid, node=Node, opts=#opts{type=Type}, selected=Sel}) -> case Sel of undefined -> {noreply, State}; R when is_integer(R) -> - Table = lists:nth(Sel+1, Tabs), - case Table#tab.protection of - private -> + case get_table(Holder, R) of + #tab{protection=private} -> self() ! {error, "Table has 'private' protection and can not be read"}; - _ -> - observer_tv_table:start_link(Grid, [{node,Node}, {type,Type}, {table,Table}]) + #tab{}=Table -> + observer_tv_table:start_link(Grid, [{node,Node}, {type,Type}, {table,Table}]); + _ -> ignore end, {noreply, State} end; @@ -202,14 +200,14 @@ handle_event(#wx{id=?ID_REFRESH_INTERVAL}, Timer = observer_lib:interval_dialog(Grid, Timer0, 10, 5*60), {noreply, State#state{timer=Timer}}; -handle_event(Event, _State) -> - error({unhandled_event, Event}). +handle_event(_Event, State) -> + {noreply, State}. handle_sync_event(_Event, _Obj, _State) -> ok. -handle_call(get_config, _, #state{timer=Timer, opt=Opt}=State) -> - #opt{type=Type, sys_hidden=Sys, unread_hidden=Unread} = Opt, +handle_call(get_config, _, #state{timer=Timer, opts=Opt}=State) -> + #opts{type=Type, sys_hidden=Sys, unread_hidden=Unread} = Opt, Conf0 = observer_lib:timer_config(Timer), Conf = Conf0#{type=>Type, sys_hidden=>Sys, unread_hidden=>Unread}, {reply, Conf, State}; @@ -220,50 +218,68 @@ handle_call(Event, From, _State) -> handle_cast(Event, _State) -> error({unhandled_cast, Event}). -handle_info(refresh_interval, State = #state{node=Node, grid=Grid, opt=Opt, - tabs=OldTabs}) -> - case get_tables(Node, Opt) of - OldTabs -> - %% no change - {noreply, State}; - Tables -> - {Tabs, Sel} = update_grid(Grid, sel(State), Opt, Tables), - Sel =/= undefined andalso wxListCtrl:ensureVisible(Grid, Sel), - {noreply, State#state{tabs=Tabs, selected=Sel}} - end; +handle_info(refresh_interval, State = #state{holder=Holder, node=Node, opts=Opt}) -> + Tables = get_tables(Node, Opt), + Holder ! {refresh, Tables}, + {noreply, State}; -handle_info({active, Node}, State = #state{parent=Parent, grid=Grid, opt=Opt0, - timer=Timer0}) -> - {Tables, Opt} = case Opt0#opt.type =:= mnesia andalso get_tables2(Node, Opt0) of +handle_info({active, Node}, State = #state{parent=Parent, holder=Holder, grid=Grid, + opts=Opt0, timer=Timer0}) -> + {Tables, Opt} = case Opt0#opts.type =:= mnesia andalso get_tables2(Node, Opt0) of Ts when is_list(Ts) -> {Ts, Opt0}; _ -> % false or error getting mnesia tables - Opt1 = Opt0#opt{type=ets}, + Opt1 = Opt0#opts{type=ets}, {get_tables(Node, Opt1), Opt1} end, - {Tabs,Sel} = update_grid(Grid, sel(State), Opt, Tables), + Holder ! {refresh, Tables}, wxWindow:setFocus(Grid), create_menus(Parent, Opt), Timer = observer_lib:start_timer(Timer0, 10), - {noreply, State#state{node=Node, tabs=Tabs, timer=Timer, opt=Opt, selected=Sel}}; + {noreply, State#state{node=Node, timer=Timer, opts=Opt}}; handle_info(not_active, State = #state{timer = Timer0}) -> Timer = observer_lib:stop_timer(Timer0), {noreply, State#state{timer=Timer}}; -handle_info({error, Error}, #state{panel=Panel,opt=Opt}=State) -> +handle_info({error, Error}, #state{panel=Panel,opts=Opt}=State) -> Str = io_lib:format("ERROR: ~ts~n",[Error]), observer_lib:display_info_dialog(Panel,Str), - case Opt#opt.type of + case Opt#opts.type of mnesia -> wxMenuBar:check(observer_wx:get_menubar(), ?ID_ETS, true); _ -> ok end, - {noreply, State#state{opt=Opt#opt{type=ets}}}; + {noreply, State#state{opts=Opt#opts{type=ets}}}; + +handle_info({refresh, Min, Min}, State = #state{grid=Grid}) -> + wxListCtrl:setItemCount(Grid, Min+1), + wxListCtrl:refreshItem(Grid, Min), %% Avoid assert in wx below if Max is 0 + observer_wx:set_status(io_lib:format("Tables: ~w", [Min+1])), + {noreply, State}; +handle_info({refresh, Min, Max}, State = #state{grid=Grid}) -> + wxListCtrl:setItemCount(Grid, Max+1), + Max > 0 andalso wxListCtrl:refreshItems(Grid, Min, Max), + observer_wx:set_status(io_lib:format("Tables: ~w", [Max+1])), + {noreply, State}; + +handle_info({selected, New, Size}, #state{grid=Grid, selected=Old} = State) -> + if + is_integer(Old), Old < Size -> + wxListCtrl:setItemState(Grid, Old, 0, ?wxLIST_STATE_SELECTED); + true -> ignore + end, + if is_integer(New) -> + wxListCtrl:setItemState(Grid, New, 16#FFFF, ?wxLIST_STATE_SELECTED), + wxListCtrl:ensureVisible(Grid, New); + true -> ignore + end, + {noreply, State#state{selected=New}}; handle_info(_Event, State) -> {noreply, State}. -terminate(_Event, _State) -> +terminate(_Event, #state{holder=Holder}) -> + Holder ! stop, ok. code_change(_, _, State) -> @@ -271,7 +287,7 @@ code_change(_, _, State) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create_menus(Parent, #opt{sys_hidden=Sys, unread_hidden=UnR, type=Type}) -> +create_menus(Parent, #opts{sys_hidden=Sys, unread_hidden=UnR, type=Type}) -> MenuEntries = [{"View", [#create_menu{id = ?ID_TABLE_INFO, text = "Table information\tCtrl-I"}, separator, @@ -298,7 +314,7 @@ get_tables(Node, Opts) -> Res -> Res end. -get_tables2(Node, #opt{type=Type, sys_hidden=Sys, unread_hidden=Unread}) -> +get_tables2(Node, #opts{type=Type, sys_hidden=Sys, unread_hidden=Unread}) -> Args = [Type, [{sys_hidden,Sys}, {unread_hidden,Unread}]], case rpc:call(Node, observer_backend, get_table_list, Args) of {badrpc, Error} -> @@ -386,49 +402,134 @@ list_to_strings([A]) -> integer_to_list(A); list_to_strings([A|B]) -> integer_to_list(A) ++ " ," ++ list_to_strings(B). -update_grid(Grid, Selected, Opt, Tables) -> - wx:batch(fun() -> update_grid2(Grid, Selected, Opt, Tables) end). - -update_grid2(Grid, {SelName,SelId}, #opt{sort_key=Sort,sort_incr=Dir}, Tables) -> - wxListCtrl:deleteAllItems(Grid), - Update = - fun(#tab{name = Name, id = Id, owner = Owner, size = Size, memory = Memory, - protection = Protection, reg_name = RegName}, - {Row, Sel}) -> - _Item = wxListCtrl:insertItem(Grid, Row, ""), - if (Row rem 2) =:= 0 -> - wxListCtrl:setItemBackgroundColour(Grid, Row, ?BG_EVEN); - true -> ignore - end, - if Protection == private -> - wxListCtrl:setItemTextColour(Grid, Row, {200,130,50}); - true -> ignore - end, - - lists:foreach(fun({_, ignore}) -> ignore; - ({Col, Val}) -> - wxListCtrl:setItem(Grid, Row, Col, observer_lib:to_str(Val)) - end, - [{0,Name}, {1,Size}, {2, Memory div 1024}, - {3,Owner}, {4,RegName}, {5,Id}]), - if SelName =:= Name, SelId =:= Id -> - wxListCtrl:setItemState(Grid, Row, 16#FFFF, ?wxLIST_STATE_SELECTED), - {Row+1, Row}; - true -> - wxListCtrl:setItemState(Grid, Row, 0, ?wxLIST_STATE_SELECTED), - {Row+1, Sel} - end - end, - ProcInfo = case Dir of - false -> lists:reverse(lists:keysort(Sort, Tables)); - true -> lists:keysort(Sort, Tables) - end, - {_, Sel} = lists:foldl(Update, {0, undefined}, ProcInfo), - {ProcInfo, Sel}. - -sel(#state{selected=Sel, tabs=Tabs}) -> - try lists:nth(Sel+1, Tabs) of - #tab{name=Name, id=Id} -> {Name, Id} - catch _:_ -> - {undefined, undefined} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Table holder needs to be in a separate process otherwise +%% the callback get_row/3 may deadlock if the process do +%% wx calls when callback is invoked. + +get_table(Table, Item) -> + get_row(Table, Item, all). + +get_row(Table, Item, Column) -> + Ref = erlang:monitor(process, Table), + Table ! {get_row, self(), Item, Column}, + receive + {'DOWN', Ref, _, _, _} -> ""; + {Table, Res} -> + erlang:demonitor(Ref), + Res end. + +get_attr(Table, Item) -> + Ref = erlang:monitor(process, Table), + Table ! {get_attr, self(), Item}, + receive + {'DOWN', Ref, _, _, _} -> wx:null(); + {Table, Res} -> + erlang:demonitor(Ref), + Res + end. + +-record(holder, {node, parent, pid, + tabs=array:new(), + sort=#sort{}, + attrs, + sel + }). + +init_table_holder(Parent, Attrs) -> + Parent ! refresh, + table_holder(#holder{node=node(), parent=Parent, attrs=Attrs}). + +table_holder(S0 = #holder{parent=Parent, tabs=Tabs0, sel=Sel0}) -> + receive + {get_attr, From, Row} -> + get_attr(From, Row, S0), + table_holder(S0); + {get_row, From, Row, Col} -> + get_row(From, Row, Col, Tabs0), + table_holder(S0); + {sort, Col} -> + STab = get_sel(Sel0, Tabs0), + Parent ! {refresh, 0, array:size(Tabs0)-1}, + S1 = sort(col2key(Col), S0), + Sel = sel_idx(STab, S1#holder.tabs), + Parent ! {selected, Sel, array:size(Tabs0)}, + table_holder(S1#holder{sel=Sel}); + {refresh, Tabs1} -> + STab = get_sel(Sel0, Tabs0), + Tabs = case S0#holder.sort of + #sort{sort_incr=false, sort_key=Col} -> + array:from_list(lists:reverse(lists:keysort(Col, Tabs1))); + #sort{sort_key=Col} -> + array:from_list(lists:keysort(Col, Tabs1)) + end, + Parent ! {refresh, 0, array:size(Tabs)-1}, + Sel = sel_idx(STab, Tabs), + Parent ! {selected, Sel,array:size(Tabs)}, + table_holder(S0#holder{tabs=Tabs, sel=Sel}); + {selected, Sel} -> + table_holder(S0#holder{sel=Sel}); + stop -> + ok; + What -> + io:format("Table holder got ~tp~n",[What]), + Parent ! {refresh, 0, array:size(Tabs0)-1}, + table_holder(S0) + end. + +get_sel(undefined, _Tabs) -> + undefined; +get_sel(Idx, Tabs) -> + array:get(Idx, Tabs). + +sel_idx(undefined, _Tabs) -> + undefined; +sel_idx(Tab, Tabs) -> + Find = fun(Idx, C, Acc) -> C =:= Tab andalso throw({found, Idx}), Acc end, + try array:foldl(Find, undefined, Tabs) + catch {found, Idx} -> Idx + end. + +sort(Col, #holder{sort=#sort{sort_key=Col, sort_incr=Incr}=S, tabs=Table0}=H) -> + Table = lists:reverse(array:to_list(Table0)), + H#holder{sort=S#sort{sort_incr=(not Incr)}, + tabs=array:from_list(Table)}; +sort(Col, #holder{sort=#sort{sort_incr=Incr}=S, tabs=Table0}=H) -> + Table = case Incr of + false -> lists:reverse(lists:keysort(Col, array:to_list(Table0))); + true -> lists:keysort(Col, array:to_list(Table0)) + end, + H#holder{sort=S#sort{sort_key=Col}, + tabs=array:from_list(Table)}. + +get_row(From, Row, Col, Table) -> + Object = array:get(Row, Table), + From ! {self(), get_col(Col, Object)}. + +get_col(all, Rec) -> + Rec; +get_col(2, #tab{}=Rec) -> %% Memory in kB + observer_lib:to_str(element(#tab.memory, Rec) div 1024); +get_col(Col, #tab{}=Rec) -> + case element(col2key(Col), Rec) of + ignore -> ""; + Val -> observer_lib:to_str(Val) + end; +get_col(_, _) -> + "". + +get_attr(From, Row, #holder{tabs=Tabs, attrs=Attrs}) -> + EvenOdd = case (Row rem 2) > 0 of + true -> Attrs#attrs.odd; + false -> Attrs#attrs.even + end, + What = try array:get(Row, Tabs) of + #tab{protection=private} -> + Attrs#attrs.deleted; + _ -> + EvenOdd + catch _ -> + EvenOdd + end, + From ! {self(), What}. diff --git a/lib/observer/test/crashdump_helper.erl b/lib/observer/test/crashdump_helper.erl index 41041682c2..b5e94a893a 100644 --- a/lib/observer/test/crashdump_helper.erl +++ b/lib/observer/test/crashdump_helper.erl @@ -21,7 +21,7 @@ -module(crashdump_helper). -export([n1_proc/2,remote_proc/2, dump_maps/0,create_maps/0, - create_binaries/0]). + create_binaries/0,create_sub_binaries/1]). -compile(r18). -include_lib("common_test/include/ct.hrl"). @@ -64,6 +64,7 @@ n1_proc(Creator,_N2,Pid2,Port2,_L) -> put(bin,Bin), put(bins,create_binaries()), put(sub_bin,SubBin), + put(sub_bins,create_sub_binaries(get(bins))), put(bignum,83974938738373873), put(neg_bignum,-38748762783736367), put(ext_pid,Pid2), @@ -82,6 +83,7 @@ n1_proc(Creator,_N2,Pid2,Port2,_L) -> link(OtherPid), % own node link(Pid2), % external node erlang:monitor(process,OtherPid), + erlang:monitor(process,init), % named process erlang:monitor(process,Pid2), code:load_file(?MODULE), @@ -104,6 +106,17 @@ create_binaries() -> <<Data:Size/unit:8>> end || Size <- Sizes]. +create_sub_binaries(Bins) -> + [create_sub_binary(Bin, Start, LenSub) || + Bin <- Bins, + Start <- [0,1,2,3,4,5,10,22], + LenSub <- [0,1,2,3,4,6,9]]. + +create_sub_binary(Bin, Start, LenSub) -> + Len = byte_size(Bin) - LenSub - Start, + <<_:Start/bytes,Sub:Len/bytes,_/bytes>> = Bin, + Sub. + %%% %%% Test dumping of maps. Dumping of maps only from OTP 20.2. %%% diff --git a/lib/observer/test/crashdump_viewer_SUITE.erl b/lib/observer/test/crashdump_viewer_SUITE.erl index 86a60e15f4..32773a779e 100644 --- a/lib/observer/test/crashdump_viewer_SUITE.erl +++ b/lib/observer/test/crashdump_viewer_SUITE.erl @@ -25,7 +25,7 @@ %% Test functions -export([all/0, suite/0,groups/0,init_per_group/2,end_per_group/2, start_stop/1,load_file/1,not_found_items/1, - non_existing/1,not_a_crashdump/1,old_crashdump/1]). + non_existing/1,not_a_crashdump/1,old_crashdump/1,new_crashdump/1]). -export([init_per_suite/1, end_per_suite/1]). -export([init_per_testcase/2, end_per_testcase/2]). @@ -83,6 +83,7 @@ all() -> non_existing, not_a_crashdump, old_crashdump, + new_crashdump, load_file, not_found_items ]. @@ -212,6 +213,25 @@ not_a_crashdump(Config) when is_list(Config) -> ok = crashdump_viewer:stop(). +%% Try to load a file with newer version than this crashdump viewer can handle +new_crashdump(Config) -> + Dump = hd(?config(dumps,Config)), + ok = start_backend(Dump), + {ok,{MaxVsn,CurrentVsn}} = crashdump_viewer:get_dump_versions(), + if MaxVsn =/= CurrentVsn -> + ct:fail("Current dump version is not equal to cdv's max version"); + true -> + ok + end, + ok = crashdump_viewer:stop(), + NewerVsn = lists:join($.,[integer_to_list(X+1) || X <- MaxVsn]), + PrivDir = ?config(priv_dir,Config), + NewDump = filename:join(PrivDir,"new_erl_crash.dump"), + ok = file:write_file(NewDump,"=erl_crash_dump:"++NewerVsn++"\n"), + {error, Reason} = start_backend(NewDump), + "This Crashdump Viewer is too old" ++_ = Reason, + ok = crashdump_viewer:stop(). + %% Load files into the tool and view all pages load_file(Config) when is_list(Config) -> case ?t:is_debug() of @@ -328,7 +348,7 @@ browse_file(File) -> io:format(" info read",[]), - lookat_all_pids(Procs), + lookat_all_pids(Procs,is_truncated(File),incomplete_allowed(File)), io:format(" pids ok",[]), lookat_all_ports(Ports), io:format(" ports ok",[]), @@ -339,6 +359,21 @@ browse_file(File) -> Procs. % used as second arg to special/2 +is_truncated(File) -> + case filename:extension(File) of + ".trunc"++_ -> + true; + _ -> + false + end. + +incomplete_allowed(File) -> + %% Incomplete heap is allowed for native libs, since some literals + %% are not dumped - and for pre OTP-20 (really pre 20.2) releases, + %% since literals were not dumped at all then. + Rel = get_rel_from_dump_name(File), + Rel < 20 orelse test_server:is_native(lists). + special(File,Procs) -> case filename:extension(File) of ".full_dist" -> @@ -368,6 +403,10 @@ special(File,Procs) -> verify_binaries(Binaries, proplists:get_value(bins,Dict)), io:format(" binaries ok",[]), + SubBinaries = crashdump_helper:create_sub_binaries(Binaries), + verify_binaries(SubBinaries, proplists:get_value(sub_bins,Dict)), + io:format(" sub binaries ok",[]), + #proc{last_calls=LastCalls} = ProcDetails, true = length(LastCalls) =< 4, @@ -420,13 +459,36 @@ special(File,Procs) -> old_attrib=undefined, old_comp_info=undefined}=Mod2, ok; + ".trunc_mod" -> + ModName = atom_to_list(?helper_mod), + {ok,Mod=#loaded_mod{},[TW]} = + crashdump_viewer:loaded_mod_details(ModName), + "WARNING: The crash dump is truncated here."++_ = TW, + #loaded_mod{current_attrib=CA,current_comp_info=CCI, + old_attrib=OA,old_comp_info=OCI} = Mod, + case lists:all(fun(undefined) -> + true; + (S) when is_list(S) -> + io_lib:printable_unicode_list(lists:flatten(S)); + (_) -> false + end, + [CA,CCI,OA,OCI]) of + true -> + ok; + false -> + ct:fail({should_be_printable_strings_or_undefined, + {CA,CCI,OA,OCI}}) + end, + ok; ".trunc_bin1" -> %% This is 'full_dist' truncated after the first %% "=binary:" %% i.e. no binary exist in the dump [#proc{pid=Pid0}|_Rest] = lists:keysort(#proc.name,Procs), Pid = pid_to_list(Pid0), - {ok,ProcDetails=#proc{},[]} = crashdump_viewer:proc_details(Pid), + %%WarnIncompleteHeap = ["WARNING: This process has an incomplete heap. Some information might be missing."], + {ok,ProcDetails=#proc{},[]} = + crashdump_viewer:proc_details(Pid), io:format(" process details ok",[]), #proc{dict=Dict} = ProcDetails, @@ -528,7 +590,7 @@ special(File,Procs) -> io:format(" process details ok",[]), #proc{dict=Dict} = ProcDetails, - io:format("~p\n", [Dict]), + %% io:format("~p\n", [Dict]), Maps = crashdump_helper:create_maps(), Maps = proplists:get_value(maps,Dict), io:format(" maps ok",[]), @@ -548,14 +610,25 @@ verify_binaries([Bin|T1], [['#CDVBin',Offset,Size,Pos]|T2]) -> verify_binaries([], []) -> ok. -lookat_all_pids([]) -> +lookat_all_pids([],_,_) -> ok; -lookat_all_pids([#proc{pid=Pid0}|Procs]) -> +lookat_all_pids([#proc{pid=Pid0}|Procs],TruncAllowed,IncompAllowed) -> Pid = pid_to_list(Pid0), - {ok,_ProcDetails=#proc{},_ProcTW} = crashdump_viewer:proc_details(Pid), - {ok,_Ets,_EtsTW} = crashdump_viewer:ets_tables(Pid), - {ok,_Timers,_TimersTW} = crashdump_viewer:timers(Pid), - lookat_all_pids(Procs). + {ok,_ProcDetails=#proc{},ProcTW} = crashdump_viewer:proc_details(Pid), + {ok,_Ets,EtsTW} = crashdump_viewer:ets_tables(Pid), + {ok,_Timers,TimersTW} = crashdump_viewer:timers(Pid), + case {ProcTW,EtsTW,TimersTW} of + {[],[],[]} -> + ok; + {["WARNING: This process has an incomplete heap."++_],[],[]} + when IncompAllowed -> + ok; % native libs, literals might not be included in dump + _ when TruncAllowed -> + ok; % truncated dump + TWs -> + ct:fail({unexpected_warning,TWs}) + end, + lookat_all_pids(Procs,TruncAllowed,IncompAllowed). lookat_all_ports([]) -> ok; @@ -603,22 +676,35 @@ do_create_dumps(DataDir,Rel) -> current -> CD3 = dump_with_args(DataDir,Rel,"instr","+Mim true"), CD4 = dump_with_strange_module_name(DataDir,Rel,"strangemodname"), - Tmp = dump_with_args(DataDir,Rel,"trunc_bytes",""), - {ok,#file_info{size=Max}} = file:read_file_info(Tmp), - ok = file:delete(Tmp), - Bytes = max(15,rand:uniform(Max)), - CD5 = dump_with_args(DataDir,Rel,"trunc_bytes", - "-env ERL_CRASH_DUMP_BYTES " ++ - integer_to_list(Bytes)), + CD5 = dump_with_size_limit_reached(DataDir,Rel,"trunc_bytes"), CD6 = dump_with_unicode_atoms(DataDir,Rel,"unicode"), CD7 = dump_with_maps(DataDir,Rel,"maps"), - TruncatedDumps = truncate_dump(CD1), - {[CD1,CD2,CD3,CD4,CD5,CD6,CD7|TruncatedDumps], DosDump}; + TruncDumpMod = truncate_dump_mod(CD1), + TruncatedDumpsBinary = truncate_dump_binary(CD1), + {[CD1,CD2,CD3,CD4,CD5,CD6,CD7,TruncDumpMod|TruncatedDumpsBinary], + DosDump}; _ -> {[CD1,CD2], DosDump} end. -truncate_dump(File) -> +truncate_dump_mod(File) -> + {ok,Bin} = file:read_file(File), + ModNameBin = atom_to_binary(?helper_mod,latin1), + NewLine = case os:type() of + {win32,_} -> <<"\r\n">>; + _ -> <<"\n">> + end, + RE = <<NewLine/binary,"=mod:",ModNameBin/binary, + NewLine/binary,"Current size: [0-9]*", + NewLine/binary,"Current attributes: ...">>, + {match,[{Pos,Len}]} = re:run(Bin,RE), + Size = Pos + Len, + <<Truncated:Size/binary,_/binary>> = Bin, + DumpName = filename:rootname(File) ++ ".trunc_mod", + file:write_file(DumpName,Truncated), + DumpName. + +truncate_dump_binary(File) -> {ok,Bin} = file:read_file(File), BinTag = <<"\n=binary:">>, Colon = <<":">>, @@ -628,7 +714,7 @@ truncate_dump(File) -> end, %% Split after "our binary" created by crashdump_helper %% (it may not be the first binary). - RE = <<"\n=binary:(?=[0-9A-Z]+",NewLine/binary,"FF:010203)">>, + RE = <<"\n=binary:(?=[0-9A-Z]+",NewLine/binary,"FF:AQID)">>, [StartBin,AfterTag] = re:split(Bin,RE,[{parts,2}]), [AddrAndSize,BinaryAndRest] = binary:split(AfterTag,Colon), [Binary,_Rest] = binary:split(BinaryAndRest,NewLine), @@ -722,6 +808,28 @@ dump_with_strange_module_name(DataDir,Rel,DumpName) -> ?t:stop_node(n1), CD. +dump_with_size_limit_reached(DataDir,Rel,DumpName) -> + Tmp = dump_with_args(DataDir,Rel,DumpName,""), + {ok,#file_info{size=Max}} = file:read_file_info(Tmp), + ok = file:delete(Tmp), + dump_with_size_limit_reached(DataDir,Rel,DumpName,Max). + +dump_with_size_limit_reached(DataDir,Rel,DumpName,Max) -> + Bytes = max(15,rand:uniform(Max)), + CD = dump_with_args(DataDir,Rel,DumpName, + "-env ERL_CRASH_DUMP_BYTES " ++ + integer_to_list(Bytes)), + {ok,#file_info{size=Size}} = file:read_file_info(CD), + if Size < Bytes -> + %% This means that the dump was actually smaller than the + %% randomly selected truncation size, so we'll just do it + %% again with a smaller numer + ok = file:delete(CD), + dump_with_size_limit_reached(DataDir,Rel,DumpName,Size-3); + true -> + CD + end. + dump_with_unicode_atoms(DataDir,Rel,DumpName) -> Opt = rel_opt(Rel), Pz = "-pz \"" ++ filename:dirname(code:which(?MODULE)) ++ "\"", @@ -794,6 +902,11 @@ dump_prefix(current) -> dump_prefix(Rel) -> lists:concat(["r",Rel,"_dump."]). +get_rel_from_dump_name(File) -> + Name = filename:basename(File), + ["r"++Rel|_] = string:split(Name,"_"), + list_to_integer(Rel). + compat_rel(current) -> ""; compat_rel(Rel) -> diff --git a/lib/observer/test/observer_SUITE.erl b/lib/observer/test/observer_SUITE.erl index 0db2c1ea77..fd4f93f662 100644 --- a/lib/observer/test/observer_SUITE.erl +++ b/lib/observer/test/observer_SUITE.erl @@ -113,7 +113,12 @@ appup_file(Config) when is_list(Config) -> basic(suite) -> []; basic(doc) -> [""]; basic(Config) when is_list(Config) -> - timer:send_after(100, "foobar"), %% Otherwise the timer server gets added to procs + %% Start these before + wx:new(), + wx:destroy(), + timer:send_after(100, "foobar"), + {foo, node@machine} ! dummy_msg, %% start distribution stuff + %% Otherwise ever lasting servers gets added to procs ProcsBefore = processes(), ProcInfoBefore = [{P,process_info(P)} || P <- ProcsBefore], NumProcsBefore = length(ProcsBefore), diff --git a/lib/observer/vsn.mk b/lib/observer/vsn.mk index 5f43198f85..fc1fca0925 100644 --- a/lib/observer/vsn.mk +++ b/lib/observer/vsn.mk @@ -1 +1 @@ -OBSERVER_VSN = 2.5 +OBSERVER_VSN = 2.6 diff --git a/lib/odbc/doc/src/notes.xml b/lib/odbc/doc/src/notes.xml index 6a8b0485eb..2aa55ca99c 100644 --- a/lib/odbc/doc/src/notes.xml +++ b/lib/odbc/doc/src/notes.xml @@ -32,7 +32,22 @@ <p>This document describes the changes made to the odbc application. </p> - <section><title>ODBC 2.12</title> + <section><title>ODBC 2.12.1</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + +<section><title>ODBC 2.12</title> <section><title>Improvements and New Features</title> <list> diff --git a/lib/odbc/vsn.mk b/lib/odbc/vsn.mk index 2e313570e1..3f7677a71d 100644 --- a/lib/odbc/vsn.mk +++ b/lib/odbc/vsn.mk @@ -1 +1 @@ -ODBC_VSN = 2.12 +ODBC_VSN = 2.12.1 diff --git a/lib/orber/doc/src/notes.xml b/lib/orber/doc/src/notes.xml index 5a82270b28..35da4f73da 100644 --- a/lib/orber/doc/src/notes.xml +++ b/lib/orber/doc/src/notes.xml @@ -33,7 +33,28 @@ <file>notes.xml</file> </header> - <section><title>Orber 3.8.3</title> + <section><title>Orber 3.8.4</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + <item> + <p> Removed the man warnings by using the code tag + instead of c tag. </p> + <p> + Own Id: OTP-14673</p> + </item> + </list> + </section> + +</section> + +<section><title>Orber 3.8.3</title> <section><title>Improvements and New Features</title> <list> diff --git a/lib/orber/vsn.mk b/lib/orber/vsn.mk index 595e686cb7..bfd3f283b5 100644 --- a/lib/orber/vsn.mk +++ b/lib/orber/vsn.mk @@ -1 +1 @@ -ORBER_VSN = 3.8.3 +ORBER_VSN = 3.8.4 diff --git a/lib/os_mon/doc/src/notes.xml b/lib/os_mon/doc/src/notes.xml index b29a64155e..cec0856a8b 100644 --- a/lib/os_mon/doc/src/notes.xml +++ b/lib/os_mon/doc/src/notes.xml @@ -31,6 +31,21 @@ </header> <p>This document describes the changes made to the OS_Mon application.</p> +<section><title>Os_Mon 2.4.4</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + <section><title>Os_Mon 2.4.3</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/os_mon/vsn.mk b/lib/os_mon/vsn.mk index e4250f577b..eb4f13ea9e 100644 --- a/lib/os_mon/vsn.mk +++ b/lib/os_mon/vsn.mk @@ -1 +1 @@ -OS_MON_VSN = 2.4.3 +OS_MON_VSN = 2.4.4 diff --git a/lib/otp_mibs/doc/src/notes.xml b/lib/otp_mibs/doc/src/notes.xml index dbd2f47ffb..c99148a904 100644 --- a/lib/otp_mibs/doc/src/notes.xml +++ b/lib/otp_mibs/doc/src/notes.xml @@ -32,6 +32,21 @@ <p>This document describes the changes made to the OTP_Mibs application.</p> +<section><title>Otp_Mibs 1.1.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + <section><title>Otp_Mibs 1.1.1</title> <section><title>Improvements and New Features</title> diff --git a/lib/otp_mibs/vsn.mk b/lib/otp_mibs/vsn.mk index 7a793007ee..13406cb5b1 100644 --- a/lib/otp_mibs/vsn.mk +++ b/lib/otp_mibs/vsn.mk @@ -1,4 +1,4 @@ -OTP_MIBS_VSN = 1.1.1 +OTP_MIBS_VSN = 1.1.2 # Note: The branch 'otp_mibs' is defunct as of otp_mibs-1.0.4 and # should NOT be used again. diff --git a/lib/parsetools/doc/src/notes.xml b/lib/parsetools/doc/src/notes.xml index 3fa7169f50..b3370a06ab 100644 --- a/lib/parsetools/doc/src/notes.xml +++ b/lib/parsetools/doc/src/notes.xml @@ -31,6 +31,21 @@ </header> <p>This document describes the changes made to the Parsetools application.</p> +<section><title>Parsetools 2.1.6</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Warnings about unused functions in <c>leexinc.hrl</c> + are suppressed. </p> + <p> + Own Id: OTP-14697</p> + </item> + </list> + </section> + +</section> + <section><title>Parsetools 2.1.5</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/parsetools/vsn.mk b/lib/parsetools/vsn.mk index 502ca00a47..b6d2ce0cd4 100644 --- a/lib/parsetools/vsn.mk +++ b/lib/parsetools/vsn.mk @@ -1 +1 @@ -PARSETOOLS_VSN = 2.1.5 +PARSETOOLS_VSN = 2.1.6 diff --git a/lib/public_key/asn1/PKCS-7.asn1 b/lib/public_key/asn1/PKCS-7.asn1 index e76f928acb..e9c188be39 100644 --- a/lib/public_key/asn1/PKCS-7.asn1 +++ b/lib/public_key/asn1/PKCS-7.asn1 @@ -124,7 +124,7 @@ SignerInfoAuthenticatedAttributes ::= CHOICE { -- Also defined in X.509 -- Redeclared here as a parameterized type -AlgorithmIdentifierPKSC-7 {ALGORITHM:IOSet} ::= SEQUENCE { +AlgorithmIdentifierPKCS-7 {ALGORITHM:IOSet} ::= SEQUENCE { algorithm ALGORITHM.&id({IOSet}), parameters ALGORITHM.&Type({IOSet}{@algorithm}) OPTIONAL } @@ -146,21 +146,21 @@ CRLSequence ::= SEQUENCE OF CertificateList ContentEncryptionAlgorithmIdentifier ::= - AlgorithmIdentifierPKSC-7 {{ContentEncryptionAlgorithms}} + AlgorithmIdentifierPKCS-7 {{ContentEncryptionAlgorithms}} ContentEncryptionAlgorithms ALGORITHM ::= { ... -- add any application-specific algorithms here } DigestAlgorithmIdentifier ::= - AlgorithmIdentifierPKSC-7 {{DigestAlgorithms}} + AlgorithmIdentifierPKCS-7 {{DigestAlgorithms}} DigestAlgorithms ALGORITHM ::= { ... -- add any application-specific algorithms here } DigestEncryptionAlgorithmIdentifier ::= - AlgorithmIdentifierPKSC-7 {{DigestEncryptionAlgorithms}} + AlgorithmIdentifierPKCS-7 {{DigestEncryptionAlgorithms}} DigestEncryptionAlgorithms ALGORITHM ::= { ... -- add any application-specific algorithms here @@ -182,7 +182,7 @@ IssuerAndSerialNumber ::= SEQUENCE { } KeyEncryptionAlgorithmIdentifier ::= - AlgorithmIdentifierPKSC-7 {{KeyEncryptionAlgorithms}} + AlgorithmIdentifierPKCS-7 {{KeyEncryptionAlgorithms}} KeyEncryptionAlgorithms ALGORITHM ::= { ... -- add any application-specific algorithms here diff --git a/lib/public_key/doc/src/notes.xml b/lib/public_key/doc/src/notes.xml index 7a7c828760..11012ee9e5 100644 --- a/lib/public_key/doc/src/notes.xml +++ b/lib/public_key/doc/src/notes.xml @@ -35,6 +35,55 @@ <file>notes.xml</file> </header> +<section><title>Public_Key 1.5.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Fixed a bug in <c>public_key:ssh_encode/2</c> that made + it possible to erroneously encode e.g. an RSA key with + another type e.g. ECDSA in the resulting binary.</p> + <p> + Own Id: OTP-14570 Aux Id: ERIERL-52, OTP-14676 </p> + </item> + <item> + <p> + Corrected handling of parameterized EC keys in + public_key:generate_key/1 so that it will work as + expected instead of causing a runtime error in crypto.</p> + <p> + Own Id: OTP-14620</p> + </item> + </list> + </section> + +</section> + +<section><title>Public_Key 1.5.1</title> + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + Hostname verification: Add handling of the general name + <c>iPAddress</c> in certificate's subject alternative + name extension (<c>subjAltName</c>).</p> + <p> + Own Id: OTP-14653</p> + </item> + <item> + <p> + Correct key handling in pkix_test_data/1 and use a + generic example mail address instead of an existing one.</p> + <p> + Own Id: OTP-14766</p> + </item> + </list> + </section> + +</section> + <section><title>Public_Key 1.5</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/public_key/doc/src/public_key.xml b/lib/public_key/doc/src/public_key.xml index 5230cef496..dea35bc390 100644 --- a/lib/public_key/doc/src/public_key.xml +++ b/lib/public_key/doc/src/public_key.xml @@ -774,6 +774,7 @@ fun(#'DistributionPoint'{}, #'CertificateList'{}, <func> <name>pkix_test_data(Options) -> Config </name> + <name>pkix_test_data([chain_opts()]) -> [conf_opt()]</name> <fsummary>Creates certificate test data.</fsummary> <type> <v>Options = #{chain_type() := chain_opts()} </v> @@ -781,30 +782,83 @@ fun(#'DistributionPoint'{}, #'CertificateList'{}, <v>chain_type() = server_chain | client_chain </v> - <v>chain_opts() = #{chain_end() := [cert_opt()], - intermediates => [[cert_opt()]]}</v> - <d>A valid chain must have at least a ROOT and a peer cert</d> - - <v>chain_end() = root | peer </v> - + <v>chain_opts() = #{root := [cert_opt()] | root_cert(), + peer := [cert_opt()], + intermediates => [[cert_opt()]]}</v> + <d> + A valid chain must have at least a ROOT and a peer cert. + The root cert can be given either as a cert pre-generated by + <seealso marker="#pkix_test_root_cert-2"> + pkix_test_root_cert/2 + </seealso>, or as root cert generation options. + </d> + <v>root_cert() = #{cert := der_encoded(), key := Key}</v> + <d> + A root certificate generated by + <seealso marker="#pkix_test_root_cert-2"> + pkix_test_root_cert/2 + </seealso>. + </d> <v>cert_opt() = {Key, Value}</v> <d>For available options see <seealso marker="#cert_opt"> cert_opt()</seealso> below.</d> <v>Config = #{server_config := [conf_opt()], client_config := [conf_opt()]}</v> - <v>conf_opt() = {cert, der_encoded()} | {key, der_encoded()} |{cacerts, [der_encoded()]}</v> - <d>This is a subset of the type <seealso marker="ssl:ssl#type-ssloption"> ssl:ssl_option()</seealso> </d> + <v>conf_opt() = {cert, der_encoded()} | {key, PrivateKey} |{cacerts, [der_encoded()]}</v> + <d> + This is a subset of the type + <seealso marker="ssl:ssl#type-ssloption"> ssl:ssl_option()</seealso>. + <c>PrivateKey</c> is what + <seealso marker="#generate_key-1">generate_key/1</seealso> + returns. + </d> </type> <desc> - <p>Creates certificate test data to facilitate automated testing - of applications using X509-certificates often through - SSL/TLS. The test data can be used when you have control - over both the client and the server in a test scenario. + <p> + Creates certificate configuration(s) consisting of certificate + and its private key plus CA certificate bundle, for a client + and a server, intended to facilitate automated testing + of applications using X509-certificates, + often through SSL/TLS. The test data can be used + when you have control over both the client and the server + in a test scenario. + </p> + <p> + When this function is called with a map containing + client and server chain specifications; + it generates both a client and a server certificate chain + where the <c>cacerts</c> + returned for the server contains the root cert the server + should trust and the intermediate certificates the server + should present to connecting clients. + The root cert the server should trust is the one used + as root of the client certificate chain. + Vice versa applies to the <c>cacerts</c> returned for the client. + The root cert(s) can either be pre-generated with + <seealso marker="#pkix_test_root_cert-2"> + pkix_test_root_cert/2 + </seealso>, or if options are specified; it is (they are) + generated. + </p> + <p> + When this function is called with a list of certificate options; + it generates a configuration with just one node certificate + where <c>cacerts</c> contains the root cert + and the intermediate certs that should be presented to a peer. + In this case the same root cert must be used for all peers. + This is useful in for example an Erlang distributed cluster + where any node, towards another node, acts either + as a server or as a client depending on who connects to whom. + The generated certificate contains a subject altname, + which is not needed in a client certificate, + but makes the certificate useful for both roles. + </p> + <p> + The <marker id="cert_opt"/><c>cert_opt()</c> + type consists of the following options: </p> - - <p> The <marker id="cert_opt"/> cert_opt() type consists of the following options: </p> <taglist> <tag> {digest, digest_type()}</tag> <item><p>Hash algorithm to be used for @@ -851,6 +905,36 @@ fun(#'DistributionPoint'{}, #'CertificateList'{}, </desc> </func> + <func> + <name>pkix_test_root_cert(Name, Options) -> RootCert</name> + <fsummary>Generates a test data root cert.</fsummary> + <type> + <v>Name = string()</v> + <d>The root certificate name.</d> + <v>Options = [cert_opt()]</v> + <d> + For available options see + <seealso marker="#cert_opt">cert_opt()</seealso> + under + <seealso marker="#pkix_test_data-1">pkix_test_data/1</seealso>. + </d> + <v>RootCert = #{cert := der_encoded(), key := Key}</v> + <d> + A root certificate and key. The <c>Key</c> is generated by + <seealso marker="#generate_key-1">generate_key/1</seealso>. + </d> + </type> + <desc> + <p> + Generates a root certificate that can be used + in multiple calls to + <seealso marker="#pkix_test_data-1">pkix_test_data/1</seealso> + when you want the same root certificate for + several generated certificates. + </p> + </desc> + </func> + <func> <name>pkix_verify(Cert, Key) -> boolean()</name> <fsummary>Verifies PKIX x.509 certificate signature.</fsummary> diff --git a/lib/public_key/src/pubkey_cert.erl b/lib/public_key/src/pubkey_cert.erl index 76fd0f8133..c433a96585 100644 --- a/lib/public_key/src/pubkey_cert.erl +++ b/lib/public_key/src/pubkey_cert.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2008-2016. All Rights Reserved. +%% Copyright Ericsson AB 2008-2017. 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. @@ -33,11 +33,12 @@ is_fixed_dh_cert/1, verify_data/1, verify_fun/4, select_extension/2, match_name/3, extensions_list/1, cert_auth_key_id/1, time_str_2_gregorian_sec/1, - gen_test_certs/1]). + gen_test_certs/1, root_cert/2]). -define(NULL, 0). --export_type([chain_opts/0, test_config/0]). +-export_type([cert_opt/0, chain_opts/0, conf_opt/0, + test_config/0, test_root_cert/0]). -type cert_opt() :: {digest, public_key:digest_type()} | {key, public_key:key_params() | public_key:private_key()} | @@ -46,9 +47,12 @@ -type chain_end() :: root | peer. -type chain_opts() :: #{chain_end() := [cert_opt()], intermediates => [[cert_opt()]]}. -type conf_opt() :: {cert, public_key:der_encoded()} | - {key, public_key:der_encoded()} | + {key, public_key:private_key()} | {cacerts, [public_key:der_encoded()]}. --type test_config() :: #{server_config := [conf_opt()], client_config := [conf_opt()]}. +-type test_config() :: + #{server_config := [conf_opt()], client_config := [conf_opt()]}. +-type test_root_cert() :: + #{cert := binary(), key := public_key:private_key()}. %%==================================================================== %% Internal application APIu %%==================================================================== @@ -430,31 +434,94 @@ match_name(Fun, Name, PermittedName, [Head | Tail]) -> false -> match_name(Fun, Name, Head, Tail) end. + %%% --spec gen_test_certs(#{server_chain:= chain_opts(), client_chain:= chain_opts()}) -> test_config(). - -%% Generates server and and client configuration for testing +-spec gen_test_certs(#{server_chain:= chain_opts(), + client_chain:= chain_opts()} | + chain_opts()) -> + test_config() | + [conf_opt()]. +%% +%% Generates server and and client configuration for testing %% purposes. All certificate options have default values -gen_test_certs(#{client_chain := #{root := ClientRootConf, - intermediates := ClientCAs, - peer := ClientPeer}, - server_chain := - #{root := ServerRootConf, - intermediates := ServerCAs, - peer := ServerPeer}}) -> - SRootKey = gen_key(proplists:get_value(key, ServerRootConf, default_key_gen())), - CRootKey = gen_key(proplists:get_value(key, ClientRootConf, default_key_gen())), - ServerRoot = root_cert("server", SRootKey, ClientRootConf), - ClientRoot = root_cert("client", CRootKey, ServerRootConf), - - [{ServerDERCert, ServerDERKey} | ServerCAsKeys] = config(server, ServerRoot, - SRootKey, lists:reverse([ServerPeer | lists:reverse(ServerCAs)])), - [{ClientDERCert, ClientDERKey} | ClientCAsKeys] = config(client, ClientRoot, - CRootKey, lists:reverse([ClientPeer | lists:reverse(ClientCAs)])), - ServerDERCA = ca_config(ClientRoot, ServerCAsKeys), - ClientDERCA = ca_config(ServerRoot, ClientCAsKeys), - #{server_config => [{cert, ServerDERCert}, {key, ServerDERKey}, {cacerts, ServerDERCA}], - client_config => [{cert, ClientDERCert}, {key, ClientDERKey}, {cacerts, ClientDERCA}]}. +gen_test_certs( + #{client_chain := + #{root := ClientRoot, + intermediates := ClientCAs, + peer := ClientPeer}, + server_chain := + #{root := ServerRoot, + intermediates := ServerCAs, + peer := ServerPeer}}) -> + #{cert := ServerRootCert, key := ServerRootKey} = + case ServerRoot of + #{} -> + ServerRoot; + ServerRootConf when is_list(ServerRootConf) -> + root_cert("SERVER ROOT CA", ServerRootConf) + end, + #{cert := ClientRootCert, key := ClientRootKey} = + case ClientRoot of + #{} -> + ClientRoot; + ClientRootConf when is_list(ClientRootConf) -> + root_cert("CLIENT ROOT CA", ClientRootConf) + end, + [{ServerDERCert, ServerDERKey} | ServerCAsKeys] = + config( + server, ServerRootCert, ServerRootKey, + lists:reverse([ServerPeer | lists:reverse(ServerCAs)])), + [{ClientDERCert, ClientDERKey} | ClientCAsKeys] = + config( + client, ClientRootCert, ClientRootKey, + lists:reverse([ClientPeer | lists:reverse(ClientCAs)])), + ServerDERCA = ca_config(ClientRootCert, ServerCAsKeys), + ClientDERCA = ca_config(ServerRootCert, ClientCAsKeys), + #{server_config => + [{cert, ServerDERCert}, {key, ServerDERKey}, + {cacerts, ServerDERCA}], + client_config => + [{cert, ClientDERCert}, {key, ClientDERKey}, + {cacerts, ClientDERCA}]}; +%% +%% Generates a node configuration for testing purposes, +%% when using the node server cert also for the client. +%% All certificate options have default values +gen_test_certs( + #{root := Root, intermediates := CAs, peer := Peer}) -> + #{cert := RootCert, key := RootKey} = + case Root of + #{} -> + Root; + RootConf when is_list(RootConf) -> + root_cert("SERVER ROOT CA", RootConf) + end, + [{DERCert, DERKey} | CAsKeys] = + config( + server, RootCert, RootKey, + lists:reverse([Peer | lists:reverse(CAs)])), + DERCAs = ca_config(RootCert, CAsKeys), + [{cert, DERCert}, {key, DERKey}, {cacerts, DERCAs}]. + +%%% +-spec root_cert(string(), [cert_opt()]) -> test_root_cert(). +%% +%% Generate a self-signed root cert +root_cert(Name, Opts) -> + PrivKey = gen_key(proplists:get_value(key, Opts, default_key_gen())), + TBS = cert_template(), + Issuer = subject("root", Name), + OTPTBS = + TBS#'OTPTBSCertificate'{ + signature = sign_algorithm(PrivKey, Opts), + issuer = Issuer, + validity = validity(Opts), + subject = Issuer, + subjectPublicKeyInfo = public_key(PrivKey), + extensions = extensions(undefined, ca, Opts) + }, + #{cert => public_key:pkix_sign(OTPTBS, PrivKey), + key => PrivKey}. %%-------------------------------------------------------------------- %%% Internal functions @@ -1103,7 +1170,7 @@ missing_basic_constraints(OtpCert, SelfSigned, ValidationState, VerifyFun, UserS UserState} end. - gen_key(KeyGen) -> +gen_key(KeyGen) -> case is_key(KeyGen) of true -> KeyGen; @@ -1120,28 +1187,14 @@ is_key(#'ECPrivateKey'{}) -> is_key(_) -> false. -root_cert(Role, PrivKey, Opts) -> - TBS = cert_template(), - Issuer = issuer("root", Role, " ROOT CA"), - OTPTBS = TBS#'OTPTBSCertificate'{ - signature = sign_algorithm(PrivKey, Opts), - issuer = Issuer, - validity = validity(Opts), - subject = Issuer, - subjectPublicKeyInfo = public_key(PrivKey), - extensions = extensions(Role, ca, Opts) - }, - public_key:pkix_sign(OTPTBS, PrivKey). cert_template() -> #'OTPTBSCertificate'{ version = v3, - serialNumber = trunc(rand:uniform()*100000000)*10000 + 1, + serialNumber = erlang:unique_integer([positive, monotonic]), issuerUniqueID = asn1_NOVALUE, subjectUniqueID = asn1_NOVALUE }. -issuer(Contact, Role, Name) -> - subject(Contact, Role ++ Name). subject(Contact, Name) -> Opts = [{email, Contact ++ "@example.org"}, @@ -1176,9 +1229,11 @@ validity(Opts) -> DefFrom0 = calendar:gregorian_days_to_date(calendar:date_to_gregorian_days(date())-1), DefTo0 = calendar:gregorian_days_to_date(calendar:date_to_gregorian_days(date())+7), {DefFrom, DefTo} = proplists:get_value(validity, Opts, {DefFrom0, DefTo0}), - Format = fun({Y,M,D}) -> - lists:flatten(io_lib:format("~w~2..0w~2..0w000000Z",[Y,M,D])) - end, + Format = + fun({Y,M,D}) -> + lists:flatten( + io_lib:format("~4..0w~2..0w~2..0w000000Z",[Y,M,D])) + end, #'Validity'{notBefore={generalTime, Format(DefFrom)}, notAfter ={generalTime, Format(DefTo)}}. @@ -1240,7 +1295,6 @@ cert(Role, #'OTPCertificate'{tbsCertificate = #'OTPTBSCertificate'{subject = Iss subject = subject(Contact, atom_to_list(Role) ++ Name), subjectPublicKeyInfo = public_key(Key), extensions = extensions(Role, Type, Opts) - }, public_key:pkix_sign(OTPTBS, PrivKey). @@ -1297,7 +1351,7 @@ add_default_extensions(server, peer, Exts) -> ], add_default_extensions(Default, Exts); -add_default_extensions(_, peer, Exts) -> +add_default_extensions(client, peer, Exts) -> Exts. add_default_extensions(Defaults0, Exts) -> diff --git a/lib/public_key/src/pubkey_ssh.erl b/lib/public_key/src/pubkey_ssh.erl index a7d018e440..02c061efc9 100644 --- a/lib/public_key/src/pubkey_ssh.erl +++ b/lib/public_key/src/pubkey_ssh.erl @@ -38,6 +38,8 @@ -define(Empint(X), (mpint(X))/binary ). -define(Estring(X), (string(X))/binary ). +-define(b64enc(X), base64:encode(iolist_to_binary(X)) ). +-define(b64mime_dec(X), base64:mime_decode(iolist_to_binary(X)) ). %% Max encoded line length is 72, but conformance examples use 68 %% Comment from rfc 4716: "The following are some examples of public @@ -163,7 +165,7 @@ rfc4716_decode_line(Line, Lines, Acc) -> rfc4716_decode_lines(Lines, [{string_decode(Tag), unicode_decode(Value)} | Acc]); _ -> {Body, Rest} = join_entry([Line | Lines], []), - {lists:reverse(Acc), rfc4716_pubkey_decode(base64:mime_decode(Body)), Rest} + {lists:reverse(Acc), rfc4716_pubkey_decode(?b64mime_dec(Body)), Rest} end. join_entry([<<"---- END SSH2 PUBLIC KEY ----", _/binary>>| Lines], Entry) -> @@ -257,11 +259,11 @@ decode_comment(Comment) -> openssh_pubkey_decode(Type, Base64Enc) -> try - <<?DEC_BIN(Type,_TL), Bin/binary>> = base64:mime_decode(Base64Enc), + <<?DEC_BIN(Type,_TL), Bin/binary>> = ?b64mime_dec(Base64Enc), ssh2_pubkey_decode(Type, Bin) catch _:_ -> - {Type, base64:mime_decode(Base64Enc)} + {Type, ?b64mime_dec(Base64Enc)} end. @@ -292,12 +294,12 @@ do_encode(Type, Key, Attributes) -> rfc4716_encode(Key, [],[]) -> iolist_to_binary([begin_marker(),"\n", - split_lines(base64:encode(ssh2_pubkey_encode(Key))), + split_lines(?b64enc(ssh2_pubkey_encode(Key))), "\n", end_marker(), "\n"]); rfc4716_encode(Key, [], [_|_] = Acc) -> iolist_to_binary([begin_marker(), "\n", lists:reverse(Acc), - split_lines(base64:encode(ssh2_pubkey_encode(Key))), + split_lines(?b64enc(ssh2_pubkey_encode(Key))), "\n", end_marker(), "\n"]); rfc4716_encode(Key, [ Header | Headers], Acc) -> LinesStr = rfc4716_encode_header(Header), @@ -326,7 +328,7 @@ rfc4716_encode_value(Value) -> openssh_encode(openssh_public_key, Key, Attributes) -> Comment = proplists:get_value(comment, Attributes, ""), - Enc = base64:encode(ssh2_pubkey_encode(Key)), + Enc = ?b64enc(ssh2_pubkey_encode(Key)), iolist_to_binary([key_type(Key), " ", Enc, " ", Comment, "\n"]); openssh_encode(auth_keys, Key, Attributes) -> @@ -351,10 +353,10 @@ openssh_encode(known_hosts, Key, Attributes) -> end. openssh_ssh2_auth_keys_encode(undefined, Key, Comment) -> - iolist_to_binary([key_type(Key)," ", base64:encode(ssh2_pubkey_encode(Key)), line_end(Comment)]); + iolist_to_binary([key_type(Key)," ", ?b64enc(ssh2_pubkey_encode(Key)), line_end(Comment)]); openssh_ssh2_auth_keys_encode(Options, Key, Comment) -> iolist_to_binary([comma_list_encode(Options, []), " ", - key_type(Key)," ", base64:encode(ssh2_pubkey_encode(Key)), line_end(Comment)]). + key_type(Key)," ", ?b64enc(ssh2_pubkey_encode(Key)), line_end(Comment)]). openssh_ssh1_auth_keys_encode(undefined, Bits, #'RSAPublicKey'{modulus = N, publicExponent = E}, @@ -369,7 +371,7 @@ openssh_ssh1_auth_keys_encode(Options, Bits, openssh_ssh2_know_hosts_encode(Hostnames, Key, Comment) -> iolist_to_binary([comma_list_encode(Hostnames, []), " ", - key_type(Key)," ", base64:encode(ssh2_pubkey_encode(Key)), line_end(Comment)]). + key_type(Key)," ", ?b64enc(ssh2_pubkey_encode(Key)), line_end(Comment)]). openssh_ssh1_known_hosts_encode(Hostnames, Bits, #'RSAPublicKey'{modulus = N, publicExponent = E}, diff --git a/lib/public_key/src/public_key.erl b/lib/public_key/src/public_key.erl index 6788c1ee92..034126655c 100644 --- a/lib/public_key/src/public_key.erl +++ b/lib/public_key/src/public_key.erl @@ -59,7 +59,8 @@ pkix_crl_verify/2, pkix_crl_issuer/1, short_name_hash/1, - pkix_test_data/1 + pkix_test_data/1, + pkix_test_root_cert/2 ]). -export_type([public_key/0, private_key/0, pem_entry/0, @@ -1033,10 +1034,12 @@ short_name_hash({rdnSequence, _Attributes} = Name) -> %%-------------------------------------------------------------------- --spec pkix_test_data(#{chain_type() := pubkey_cert:chain_opts()}) -> - pubkey_cert:test_config(). +-spec pkix_test_data(#{chain_type() := pubkey_cert:chain_opts()} | + pubkey_cert:chain_opts()) -> + pubkey_cert:test_config() | + [pubkey_cert:conf_opt()]. -%% Description: Generates OpenSSL-style hash of a name. +%% Description: Generates cert(s) and ssl configuration %%-------------------------------------------------------------------- pkix_test_data(#{client_chain := ClientChain0, @@ -1045,7 +1048,21 @@ pkix_test_data(#{client_chain := ClientChain0, ClientChain = maps:merge(Default, ClientChain0), ServerChain = maps:merge(Default, ServerChain0), pubkey_cert:gen_test_certs(#{client_chain => ClientChain, - server_chain => ServerChain}). + server_chain => ServerChain}); +pkix_test_data(#{} = Chain) -> + Default = #{intermediates => []}, + pubkey_cert:gen_test_certs(maps:merge(Default, Chain)). + +%%-------------------------------------------------------------------- +-spec pkix_test_root_cert( + Name :: string(), Opts :: [pubkey_cert:cert_opt()]) -> + pubkey_cert:test_root_cert(). + +%% Description: Generates a root cert suitable for pkix_test_data/1 +%%-------------------------------------------------------------------- + +pkix_test_root_cert(Name, Opts) -> + pubkey_cert:root_cert(Name, Opts). %%-------------------------------------------------------------------- %%% Internal functions diff --git a/lib/public_key/test/public_key_SUITE.erl b/lib/public_key/test/public_key_SUITE.erl index 579df160bc..449d1fc040 100644 --- a/lib/public_key/test/public_key_SUITE.erl +++ b/lib/public_key/test/public_key_SUITE.erl @@ -64,7 +64,9 @@ all() -> groups() -> [{pem_decode_encode, [], [dsa_pem, rsa_pem, ec_pem, encrypted_pem, dh_pem, cert_pem, pkcs7_pem, pkcs10_pem, ec_pem2, - ec_pem_encode_generated, gen_ec_param]}, + ec_pem_encode_generated, + gen_ec_param_prime_field, gen_ec_param_char_2_field + ]}, {ssh_public_key_decode_encode, [], [ssh_rsa_public_key, ssh_dsa_public_key, ssh_ecdsa_public_key, ssh_rfc4716_rsa_comment, ssh_rfc4716_dsa_comment, @@ -97,14 +99,20 @@ end_per_group(_GroupName, Config) -> Config. %%------------------------------------------------------------------- -init_per_testcase(Case, Config) when Case == pkix_test_data_all_default; - Case == gen_ec_param -> +init_per_testcase(pkix_test_data_all_default, Config) -> case crypto:ec_curves() of [] -> {skip, missing_ecc_support}; _ -> - init_common_per_testcase(Config) + init_common_per_testcase(Config) end; + +init_per_testcase(gen_ec_param_prime_field=TC, Config) -> + init_per_testcase_gen_ec_param(TC, secp521r1, Config); + +init_per_testcase(gen_ec_param_char_2_field=TC, Config) -> + init_per_testcase_gen_ec_param(TC, sect571r1, Config); + init_per_testcase(TestCase, Config) -> case TestCase of ssh_hostkey_fingerprint_md5_implicit -> init_fingerprint_testcase([md5], Config); @@ -1021,8 +1029,6 @@ pkix_verify_hostname_subjAltName_IP(Config) -> true = public_key:pkix_verify_hostname(Cert, [{ip, {10,67,16,75}}]), false = public_key:pkix_verify_hostname(Cert, [{ip, {1,2,3,4}}]), false = public_key:pkix_verify_hostname(Cert, [{ip, {10,11,12,13}}]). - - %%-------------------------------------------------------------------- pkix_iso_rsa_oid() -> [{doc, "Test workaround for supporting certs that use ISO oids" @@ -1207,12 +1213,19 @@ short_crl_issuer_hash(Config) when is_list(Config) -> Issuer = public_key:pkix_crl_issuer(CrlDER), CrlIssuerHash = public_key:short_name_hash(Issuer). + %%-------------------------------------------------------------------- -gen_ec_param() -> - [{doc, "Generate key with EC parameters"}]. -gen_ec_param(Config) when is_list(Config) -> +gen_ec_param_prime_field() -> + [{doc, "Generate key with EC prime_field parameters"}]. +gen_ec_param_prime_field(Config) when is_list(Config) -> + Datadir = proplists:get_value(data_dir, Config), + do_gen_ec_param(filename:join(Datadir, "ec_key_param0.pem")). + +%%-------------------------------------------------------------------- +gen_ec_param_char_2_field() -> + [{doc, "Generate key with EC characteristic_two_field parameters"}]. +gen_ec_param_char_2_field(Config) when is_list(Config) -> Datadir = proplists:get_value(data_dir, Config), - do_gen_ec_param(filename:join(Datadir, "ec_key_param0.pem")), do_gen_ec_param(filename:join(Datadir, "ec_key_param1.pem")). %%-------------------------------------------------------------------- @@ -1299,6 +1312,30 @@ do_gen_ec_param(File) -> ct:fail({key_gen_fail, File}) end. +init_per_testcase_gen_ec_param(TC, Curve, Config) -> + case crypto:ec_curves() of + [] -> + {skip, missing_ec_support}; + Curves -> + case lists:member(Curve, Curves) + andalso crypto_supported_curve(Curve, Curves) + of + true -> + init_common_per_testcase(Config); + false -> + {skip, {missing_ec_support, Curve}} + end + end. + + +crypto_supported_curve(Curve, Curves) -> + try crypto:generate_key(ecdh, Curve) of + {error,_} -> false; % Just in case crypto is changed in the future... + _-> true + catch + _:_-> false + end. + incorrect_countryname_pkix_cert() -> <<48,130,5,186,48,130,4,162,160,3,2,1,2,2,7,7,250,61,63,6,140,137,48,13,6,9,42, 134,72,134,247,13,1,1,5,5,0,48,129,220,49,11,48,9,6,3,85,4,6,19,2,85,83,49, 16,48,14,6,3,85,4,8,19,7,65,114,105,122,111,110,97,49,19,48,17,6,3,85,4,7,19, 10,83,99,111,116,116,115,100,97,108,101,49,37,48,35,6,3,85,4,10,19,28,83,116, 97,114,102,105,101,108,100,32,84,101,99,104,110,111,108,111,103,105,101,115, 44,32,73,110,99,46,49,57,48,55,6,3,85,4,11,19,48,104,116,116,112,58,47,47,99, 101,114,116,105,102,105,99,97,116,101,115,46,115,116,97,114,102,105,101,108, 100,116,101,99,104,46,99,111,109,47,114,101,112,111,115,105,116,111,114,121, 49,49,48,47,6,3,85,4,3,19,40,83,116,97,114,102,105,101,108,100,32,83,101,99, 117,114,101,32,67,101,114,116,105,102,105,99,97,116,105,111,110,32,65,117, 116,104,111,114,105,116,121,49,17,48,15,6,3,85,4,5,19,8,49,48,54,56,56,52,51, 53,48,30,23,13,49,48,49,48,50,51,48,49,51,50,48,53,90,23,13,49,50,49,48,50, 51,48,49,51,50,48,53,90,48,122,49,11,48,9,6,3,85,4,6,12,2,85,83,49,11,48,9,6, 3,85,4,8,12,2,65,90,49,19,48,17,6,3,85,4,7,12,10,83,99,111,116,116,115,100, 97,108,101,49,38,48,36,6,3,85,4,10,12,29,83,112,101,99,105,97,108,32,68,111, 109,97,105,110,32,83,101,114,118,105,99,101,115,44,32,73,110,99,46,49,33,48, 31,6,3,85,4,3,12,24,42,46,108,111,103,105,110,46,115,101,99,117,114,101,115, 101,114,118,101,114,46,110,101,116,48,130,1,34,48,13,6,9,42,134,72,134,247, 13,1,1,1,5,0,3,130,1,15,0,48,130,1,10,2,130,1,1,0,185,136,240,80,141,36,124, 245,182,130,73,19,188,74,166,117,72,228,185,209,43,129,244,40,44,193,231,11, 209,12,234,88,43,142,1,162,48,122,17,95,230,105,171,131,12,147,46,204,36,80, 250,171,33,253,35,62,83,22,71,212,186,141,14,198,89,89,121,204,224,122,246, 127,110,188,229,162,67,95,6,74,231,127,99,131,7,240,85,102,203,251,50,58,58, 104,245,103,181,183,134,32,203,121,232,54,32,188,139,136,112,166,126,14,91, 223,153,172,164,14,61,38,163,208,215,186,210,136,213,143,70,147,173,109,217, 250,169,108,31,211,104,238,103,93,182,59,165,43,196,189,218,241,30,148,240, 109,90,69,176,194,52,116,173,151,135,239,10,209,179,129,192,102,75,11,25,168, 223,32,174,84,223,134,70,167,55,172,143,27,130,123,226,226,7,34,142,166,39, 48,246,96,231,150,84,220,106,133,193,55,95,159,227,24,249,64,36,1,142,171,16, 202,55,126,7,156,15,194,22,116,53,113,174,104,239,203,120,45,131,57,87,84, 163,184,27,83,57,199,91,200,34,43,98,61,180,144,76,65,170,177,2,3,1,0,1,163, 130,1,224,48,130,1,220,48,15,6,3,85,29,19,1,1,255,4,5,48,3,1,1,0,48,29,6,3, 85,29,37,4,22,48,20,6,8,43,6,1,5,5,7,3,1,6,8,43,6,1,5,5,7,3,2,48,14,6,3,85, 29,15,1,1,255,4,4,3,2,5,160,48,56,6,3,85,29,31,4,49,48,47,48,45,160,43,160, 41,134,39,104,116,116,112,58,47,47,99,114,108,46,115,116,97,114,102,105,101, 108,100,116,101,99,104,46,99,111,109,47,115,102,115,50,45,48,46,99,114,108, 48,83,6,3,85,29,32,4,76,48,74,48,72,6,11,96,134,72,1,134,253,110,1,7,23,2,48, 57,48,55,6,8,43,6,1,5,5,7,2,1,22,43,104,116,116,112,115,58,47,47,99,101,114, 116,115,46,115,116,97,114,102,105,101,108,100,116,101,99,104,46,99,111,109, 47,114,101,112,111,115,105,116,111,114,121,47,48,129,141,6,8,43,6,1,5,5,7,1, 1,4,129,128,48,126,48,42,6,8,43,6,1,5,5,7,48,1,134,30,104,116,116,112,58,47, 47,111,99,115,112,46,115,116,97,114,102,105,101,108,100,116,101,99,104,46,99, 111,109,47,48,80,6,8,43,6,1,5,5,7,48,2,134,68,104,116,116,112,58,47,47,99, 101,114,116,105,102,105,99,97,116,101,115,46,115,116,97,114,102,105,101,108, 100,116,101,99,104,46,99,111,109,47,114,101,112,111,115,105,116,111,114,121, 47,115,102,95,105,110,116,101,114,109,101,100,105,97,116,101,46,99,114,116, 48,31,6,3,85,29,35,4,24,48,22,128,20,73,75,82,39,209,27,188,242,161,33,106, 98,123,81,66,122,138,215,213,86,48,59,6,3,85,29,17,4,52,48,50,130,24,42,46, 108,111,103,105,110,46,115,101,99,117,114,101,115,101,114,118,101,114,46,110, 101,116,130,22,108,111,103,105,110,46,115,101,99,117,114,101,115,101,114,118, 101,114,46,110,101,116,48,29,6,3,85,29,14,4,22,4,20,138,233,191,208,157,203, 249,85,242,239,20,195,48,10,148,49,144,101,255,116,48,13,6,9,42,134,72,134, 247,13,1,1,5,5,0,3,130,1,1,0,82,31,121,162,49,50,143,26,167,202,143,61,71, 189,201,199,57,81,122,116,90,192,88,24,102,194,174,48,157,74,27,87,210,223, 253,93,3,91,150,109,120,1,110,27,11,200,198,141,222,246,14,200,71,105,41,138, 13,114,122,106,63,17,197,181,234,121,61,89,74,65,41,231,248,219,129,83,176, 219,55,107,55,211,112,98,38,49,69,77,96,221,108,123,152,12,210,159,157,141, 43,226,55,187,129,3,82,49,136,66,81,196,91,234,196,10,82,48,6,80,163,83,71, 127,102,177,93,209,129,26,104,2,84,24,255,248,161,3,244,169,234,92,122,110, 43,4,17,113,185,235,108,219,210,236,132,216,177,227,17,169,58,162,159,182, 162,93,160,229,200,9,163,229,110,121,240,168,232,14,91,214,188,196,109,210, 164,222,0,109,139,132,113,91,16,118,173,178,176,80,132,34,41,199,51,206,250, 224,132,60,115,192,94,107,163,219,212,226,225,65,169,148,108,213,46,174,173, 103,110,189,229,166,149,254,31,51,44,144,108,187,182,11,251,201,206,86,138, 208,59,51,86,132,235,81,225,88,34,190,8,184>>. diff --git a/lib/public_key/vsn.mk b/lib/public_key/vsn.mk index bb96c2237d..99a0cc087e 100644 --- a/lib/public_key/vsn.mk +++ b/lib/public_key/vsn.mk @@ -1 +1 @@ -PUBLIC_KEY_VSN = 1.5 +PUBLIC_KEY_VSN = 1.5.2 diff --git a/lib/runtime_tools/doc/src/LTTng.xml b/lib/runtime_tools/doc/src/LTTng.xml index 392d54857c..93937b3fdc 100644 --- a/lib/runtime_tools/doc/src/LTTng.xml +++ b/lib/runtime_tools/doc/src/LTTng.xml @@ -134,7 +134,7 @@ $ make </code> <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>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> </list> <p> @@ -323,7 +323,7 @@ $ make </code> <p><em>driver_init</em></p> <list type="bulleted"> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> <item><c>major : integer</c> :: Major version. Ex. <c>3</c></item> <item><c>minor : integer</c> :: Minor version. Ex. <c>1</c></item> <item><c>flags : integer</c> :: Flags. Ex. <c>1</c></item> @@ -334,7 +334,7 @@ $ make </code> <p><em>driver_start</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>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> </list> <p>Example:</p> @@ -344,7 +344,7 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> <item><c>bytes : integer</c> :: Size of data returned. Ex. <c>82</c></item> </list> <p>Example:</p> @@ -354,7 +354,7 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> <item><c>bytes : integer</c> :: Size of data returned. Ex. <c>82</c></item> </list> <p>Example:</p> @@ -364,7 +364,7 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p>Example:</p> <code type="none">driver_ready_input: { cpu_id = 5 }, { pid = "<0.189.0>", port = "#Port<0.3637>", driver = "inet_gethost 4 " }</code> @@ -373,7 +373,7 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p>Example:</p> <code type="none">driver_ready_output: { cpu_id = 5 }, { pid = "<0.194.0>", port = "#Port<0.3663>", driver = "tcp_inet" }</code> @@ -382,14 +382,14 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p>Example:</p> <code type="none">driver_timeout: { cpu_id = 5 }, { pid = "<0.196.0>", port = "#Port<0.3664>", driver = "tcp_inet" }</code> <p><em>driver_stop_select</em></p> <list type="bulleted"> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p>Example:</p> <code type="none">driver_stop_select: { cpu_id = 5 }, { driver = "unknown" }</code> @@ -398,7 +398,7 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p>Example:</p> <code type="none">driver_flush: { cpu_id = 7 }, { pid = "<0.204.0>", port = "#Port<0.3686>", driver = "tcp_inet" }</code> @@ -407,32 +407,32 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p>Example:</p> - <code type="none">driver_stop: { cpu_id = 5 }, { pid = "[]", port = "#Port<0.3673>", driver = "efile" }</code> + <code type="none">driver_stop: { cpu_id = 5 }, { pid = "[]", port = "#Port<0.3673>", driver = "tcp_inet" }</code> <p><em>driver_process_exit</em></p> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p><em>driver_ready_async</em></p> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> </list> <p>Example:</p> - <code type="none">driver_ready_async: { cpu_id = 3 }, { pid = "<0.181.0>", port = "#Port<0.3622>", driver = "efile" }</code> + <code type="none">driver_ready_async: { cpu_id = 3 }, { pid = "<0.181.0>", port = "#Port<0.3622>", driver = "tcp_inet" }</code> <p><em>driver_call</em></p> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> <item><c>command : integer</c> :: Command integer. Ex. <c>1</c></item> <item><c>bytes : integer</c> :: Size of data returned. Ex. <c>82</c></item> </list> @@ -443,7 +443,7 @@ $ make </code> <list type="bulleted"> <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> - <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"tcp_inet"</c></item> <item><c>command : integer</c> :: Command integer. Ex. <c>1</c></item> <item><c>bytes : integer</c> :: Size of data returned. Ex. <c>82</c></item> </list> diff --git a/lib/runtime_tools/doc/src/Makefile b/lib/runtime_tools/doc/src/Makefile index dad229e193..a9b0056a93 100644 --- a/lib/runtime_tools/doc/src/Makefile +++ b/lib/runtime_tools/doc/src/Makefile @@ -41,11 +41,17 @@ RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) # Target Specs # ---------------------------------------------------- XML_APPLICATION_FILES = ref_man.xml -XML_REF3_FILES = dbg.xml dyntrace.xml erts_alloc_config.xml system_information.xml msacc.xml +XML_REF3_FILES = \ + dbg.xml \ + dyntrace.xml \ + erts_alloc_config.xml \ + system_information.xml \ + msacc.xml \ + scheduler.xml XML_REF6_FILES = runtime_tools_app.xml XML_PART_FILES = part.xml -XML_CHAPTER_FILES = notes.xml notes_history.xml LTTng.xml +XML_CHAPTER_FILES = notes.xml LTTng.xml GENERATED_XML_FILES = DTRACE.xml SYSTEMTAP.xml @@ -54,7 +60,8 @@ BOOK_FILES = book.xml XML_FILES = \ $(BOOK_FILES) $(XML_CHAPTER_FILES) \ $(XML_PART_FILES) $(XML_REF3_FILES) \ - $(XML_REF6_FILES) $(XML_APPLICATION_FILES) + $(XML_REF6_FILES) $(XML_APPLICATION_FILES) \ + $(GENERATED_XML_FILES) GIF_FILES = @@ -89,7 +96,6 @@ SPECS_FLAGS = -I../../include -I../../../kernel/src # ---------------------------------------------------- # Targets # ---------------------------------------------------- -$(XML_FILES): $(GENERATED_XML_FILES) %.xml: $(ERL_TOP)/HOWTO/%.md $(ERL_TOP)/make/emd2exml $(ERL_TOP)/make/emd2exml $< $@ diff --git a/lib/runtime_tools/doc/src/notes.xml b/lib/runtime_tools/doc/src/notes.xml index 8b4d437c26..93e3e26fda 100644 --- a/lib/runtime_tools/doc/src/notes.xml +++ b/lib/runtime_tools/doc/src/notes.xml @@ -32,6 +32,21 @@ <p>This document describes the changes made to the Runtime_Tools application.</p> +<section><title>Runtime_Tools 1.12.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + <section><title>Runtime_Tools 1.12.2</title> <section><title>Improvements and New Features</title> diff --git a/lib/runtime_tools/doc/src/ref_man.xml b/lib/runtime_tools/doc/src/ref_man.xml index d2fb7a29af..eb3a6f0f5c 100644 --- a/lib/runtime_tools/doc/src/ref_man.xml +++ b/lib/runtime_tools/doc/src/ref_man.xml @@ -37,6 +37,7 @@ <xi:include href="dyntrace.xml"/> <xi:include href="erts_alloc_config.xml"/> <xi:include href="msacc.xml"/> + <xi:include href="scheduler.xml"/> <xi:include href="system_information.xml"/> </application> diff --git a/lib/runtime_tools/doc/src/scheduler.xml b/lib/runtime_tools/doc/src/scheduler.xml new file mode 100644 index 0000000000..dd8bf73bae --- /dev/null +++ b/lib/runtime_tools/doc/src/scheduler.xml @@ -0,0 +1,135 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE erlref SYSTEM "erlref.dtd"> + +<erlref> + <header> + <copyright> + <year>2018</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></title> + <prepared></prepared> + <responsible></responsible> + <docno>1</docno> + <approved></approved> + <checked></checked> + <date></date> + <rev></rev> + <file>scheduler.xml</file> + </header> + <module>scheduler</module> + <modulesummary>Measure scheduler utilization</modulesummary> + <description> + <p>This module contains utility functions for easier measurement and + calculation of scheduler utilization, otherwise obtained from calling the + more primitive <seealso marker="erts:erlang#statistics_scheduler_wall_time"> + <c>statistics(scheduler_wall_time)</c></seealso>.</p> + <p>The simplest usage is to call <seealso marker="#utilization-1"> + <c>scheduler:utilization(Seconds)</c></seealso>.</p> + </description> + + <datatypes> + <datatype> + <name name="sched_sample"/> + </datatype> + <datatype> + <name name="sched_type"/> + </datatype> + <datatype> + <name name="sched_id"/> + </datatype> + <datatype> + <name name="sched_util_result"/> + <desc> + <p>A list of tuples containing results for individual schedulers + as well as aggregated averages. <c>Util</c> is the scheduler utilization + as a floating point value between 0.0 and 1.0. <c>Percent</c> is the + same utilization as a more human readable string expressed in percent.</p> + <taglist> + <tag><c>{normal, SchedulerId, Util, Percent}</c></tag> + <item>Scheduler utilization of a normal scheduler with number + <c>SchedulerId</c>.</item> + <tag><c>{cpu, SchedulerId, Util, Percent}</c></tag> + <item>Scheduler utilization of a dirty-cpu scheduler with number + <c>SchedulerId</c>.</item> + <tag><c>{io, SchedulerId, Util, Percent}</c></tag> + <item>Scheduler utilization of a dirty-io scheduler with number + <c>SchedulerId</c>. This tuple will only exist if both samples were + taken with <seealso marker="#sample_all-0"><c>sample_all/0</c></seealso>.</item> + <tag><c>{total, Util, Percent}</c></tag> + <item>Total utilization of all normal and dirty-cpu schedulers.</item> + <tag><c>{weighted, Util, Percent}</c></tag> + <item>Total utilization of all normal and dirty-cpu schedulers, + weighted against maximum amount of available CPU time.</item> + </taglist> + </desc> + </datatype> + </datatypes> + + <funcs> + + <func> + <name name="sample" arity="0"/> + <fsummary>Get scheduler utilization sample.</fsummary> + <desc> + <p>Return a scheduler utilization sample for normal and dirty-cpu + schedulers.</p> + </desc> + </func> + + <func> + <name name="sample_all" arity="0"/> + <fsummary>Get scheduler utilization sample.</fsummary> + <desc> + <p>Return a scheduler utilization sample for all schedulers, + including dirty-io schedulers.</p> + </desc> + </func> + + <func> + <name name="utilization" arity="1" clause_i="1"/> + <fsummary>Measure scheduler utilizations during a period of time.</fsummary> + <desc> + <p>Measure utilization for normal and dirty-cpu schedulers during + <c><anno>Seconds</anno></c> seconds, and then return the result.</p> + </desc> + </func> + + <func> + <name name="utilization" arity="1" clause_i="2"/> + <fsummary>Measure scheduler utilizations since sample.</fsummary> + <desc> + <p>Calculate scheduler utilizations for the time interval from when + <c><anno>Sample</anno></c> was taken and "now". The same as calling + <c>scheduler:utilization(Sample, scheduler:sample_all())</c>.</p> + </desc> + </func> + + <func> + <name name="utilization" arity="2"/> + <fsummary>Measure scheduler utilizations between two samples.</fsummary> + <desc> + <p>Calculates scheduler utilizations for the time interval between + the two samples obtained from calling + <seealso marker="#sample-0"><c>sample/0</c></seealso> or + <seealso marker="#sample_all-0"><c>sample_all/0</c></seealso>.</p> + </desc> + </func> + + </funcs> + </erlref> diff --git a/lib/runtime_tools/doc/src/specs.xml b/lib/runtime_tools/doc/src/specs.xml index 978bd39e55..33fe7fa370 100644 --- a/lib/runtime_tools/doc/src/specs.xml +++ b/lib/runtime_tools/doc/src/specs.xml @@ -2,4 +2,5 @@ <specs xmlns:xi="http://www.w3.org/2001/XInclude"> <xi:include href="../specs/specs_system_information.xml"/> <xi:include href="../specs/specs_msacc.xml"/> + <xi:include href="../specs/specs_scheduler.xml"/> </specs> diff --git a/lib/runtime_tools/examples/efile_drv.d b/lib/runtime_tools/examples/efile_drv.d deleted file mode 100644 index a470518dd9..0000000000 --- a/lib/runtime_tools/examples/efile_drv.d +++ /dev/null @@ -1,105 +0,0 @@ -/* example usage: dtrace -q -s /path/to/efile_drv.d */ -/* - * %CopyrightBegin% - * - * Copyright Scott Lystig Fritchie 2011-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% - */ - -BEGIN -{ - op_map[1] = "OPEN"; - op_map[2] = "READ"; - op_map[3] = "LSEEK"; - op_map[4] = "WRITE"; - op_map[5] = "FSTAT"; - op_map[6] = "PWD"; - op_map[7] = "READDIR"; - op_map[8] = "CHDIR"; - op_map[9] = "FSYNC"; - op_map[10] = "MKDIR"; - op_map[11] = "DELETE"; - op_map[12] = "RENAME"; - op_map[13] = "RMDIR"; - op_map[14] = "TRUNCATE"; - op_map[15] = "READ_FILE"; - op_map[16] = "WRITE_INFO"; - op_map[19] = "LSTAT"; - op_map[20] = "READLINK"; - op_map[21] = "LINK"; - op_map[22] = "SYMLINK"; - op_map[23] = "CLOSE"; - op_map[24] = "PWRITEV"; - op_map[25] = "PREADV"; - op_map[26] = "SETOPT"; - op_map[27] = "IPREAD"; - op_map[28] = "ALTNAME"; - op_map[29] = "READ_LINE"; - op_map[30] = "FDATASYNC"; - op_map[31] = "FADVISE"; -} - -erlang*:::aio_pool-add -{ - printf("async I/O pool port %s queue len %d\n", copyinstr(arg0), arg1); -} - -erlang*:::aio_pool-get -{ - printf("async I/O pool port %s queue len %d\n", copyinstr(arg0), arg1); -} - -erlang*:::efile_drv-entry -{ - printf("efile_drv enter tag={%d,%d} %s%s | %s (%d) | args: %s %s , %d %d (port %s)\n", - arg0, arg1, - arg2 == NULL ? "" : "user tag ", - arg2 == NULL ? "" : copyinstr(arg2), - op_map[arg3], arg3, - arg4 == NULL ? "" : copyinstr(arg4), - arg5 == NULL ? "" : copyinstr(arg5), arg6, arg7, - /* NOTE: port name in args[10] is experimental */ - (args[10] == NULL) ? - "?" : copyinstr((user_addr_t) args[10])); -} - -erlang*:::efile_drv-int* -{ - printf("async I/O worker tag={%d,%d} | %s (%d) | %s\n", - arg0, arg1, op_map[arg2], arg2, probename); -} - -/* efile_drv-return error case */ -erlang*:::efile_drv-return -/arg4 == 0/ -{ - printf("efile_drv return tag={%d,%d} %s%s | %s (%d) | errno %d\n", - arg0, arg1, - arg2 == NULL ? "" : "user tag ", - arg2 == NULL ? "" : copyinstr(arg2), - op_map[arg3], arg3, - arg5); -} - -/* efile_drv-return success case */ -erlang*:::efile_drv-return -/arg4 != 0/ -{ - printf("efile_drv return tag={%d,%d} %s | %s (%d) ok\n", - arg0, arg1, - arg2 == NULL ? "" : copyinstr(arg2), - op_map[arg3], arg3); -} diff --git a/lib/runtime_tools/examples/efile_drv.systemtap b/lib/runtime_tools/examples/efile_drv.systemtap deleted file mode 100644 index 29c3637e10..0000000000 --- a/lib/runtime_tools/examples/efile_drv.systemtap +++ /dev/null @@ -1,113 +0,0 @@ -/* - * %CopyrightBegin% - * - * Copyright Scott Lystig Fritchie and Andreas Schultz, 2011-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% - */ -/* - * Note: This file assumes that you're using the non-SMP-enabled Erlang - * virtual machine, "beam". The SMP-enabled VM is called "beam.smp". - * Note that other variations of the virtual machine also have - * different names, e.g. the debug build of the SMP-enabled VM - * is "beam.debug.smp". - * - * To use a different virtual machine, replace each instance of - * "beam" with "beam.smp" or the VM name appropriate to your - * environment. - */ - -probe begin -{ - op_map[1] = "OPEN"; - op_map[2] = "READ"; - op_map[3] = "LSEEK"; - op_map[4] = "WRITE"; - op_map[5] = "FSTAT"; - op_map[6] = "PWD"; - op_map[7] = "READDIR"; - op_map[8] = "CHDIR"; - op_map[9] = "FSYNC"; - op_map[10] = "MKDIR"; - op_map[11] = "DELETE"; - op_map[12] = "RENAME"; - op_map[13] = "RMDIR"; - op_map[14] = "TRUNCATE"; - op_map[15] = "READ_FILE"; - op_map[16] = "WRITE_INFO"; - op_map[19] = "LSTAT"; - op_map[20] = "READLINK"; - op_map[21] = "LINK"; - op_map[22] = "SYMLINK"; - op_map[23] = "CLOSE"; - op_map[24] = "PWRITEV"; - op_map[25] = "PREADV"; - op_map[26] = "SETOPT"; - op_map[27] = "IPREAD"; - op_map[28] = "ALTNAME"; - op_map[29] = "READ_LINE"; - op_map[30] = "FDATASYNC"; - op_map[31] = "FADVISE"; -} - -probe process("beam").mark("aio_pool-add") -{ - printf("async I/O pool port %s queue len %d\n", user_string($arg1), $arg2); -} - -probe process("beam").mark("aio_pool-get") -{ - printf("async I/O pool port %s queue len %d\n", user_string($arg1), $arg2); -} - -probe process("beam").mark("efile_drv-entry") -{ - printf("efile_drv enter tag={%d,%d} %s%s | %s (%d) | args: %s %s , %d %d (port %s)\n", - $arg1, $arg2, - $arg3 == NULL ? "" : "user tag ", - $arg3 == NULL ? "" : user_string($arg3), - op_map[$arg4], $arg4, - $arg5 == NULL ? "" : user_string($arg5), - $arg6 == NULL ? "" : user_string($arg6), $arg7, $arg8, - /* NOTE: port name in $arg[11] is experimental */ - user_string($arg11)) -} - -probe process("beam").mark("efile_drv-int*") -{ - printf("async I/O worker tag={%d,%d} | %s (%d) | %s\n", - $arg1, $arg2, op_map[$arg3], $arg3, probefunc()); -} - -probe process("beam").mark("efile_drv-return") -{ - if ($arg5 == 0) { - /* efile_drv-return error case */ - printf("efile_drv return tag={%d,%d} %s%s | %s (%d) | errno %d\n", - $arg1, $arg2, - $arg3 == NULL ? "" : "user tag ", - $arg3 == NULL ? "" : user_string($arg3), - op_map[$arg4], $arg4, - $arg6); - } else { - /* efile_drv-return success case */ - printf("efile_drv return tag={%d,%d} %s | %s (%d) ok\n", - $arg1, $arg2, - $arg3 == NULL ? "" : user_string($arg3), - op_map[$arg4], $arg4); - } -} - -global op_map; diff --git a/lib/runtime_tools/src/Makefile b/lib/runtime_tools/src/Makefile index 5a99c6e240..6faa9c2e35 100644 --- a/lib/runtime_tools/src/Makefile +++ b/lib/runtime_tools/src/Makefile @@ -45,6 +45,7 @@ MODULES= \ system_information \ observer_backend \ ttb_autostart\ + scheduler\ msacc HRL_FILES= ../include/observer_backend.hrl diff --git a/lib/runtime_tools/src/observer_backend.erl b/lib/runtime_tools/src/observer_backend.erl index 1b075a507d..a1edde8516 100644 --- a/lib/runtime_tools/src/observer_backend.erl +++ b/lib/runtime_tools/src/observer_backend.erl @@ -293,7 +293,7 @@ fetch_stats_loop(Parent, Time) -> erlang:system_flag(scheduler_wall_time, true), receive _Msg -> - %% erlang:system_flag(scheduler_wall_time, false) + erlang:system_flag(scheduler_wall_time, false), ok after Time -> _M = Parent ! {stats, 1, @@ -340,7 +340,6 @@ etop_collect(Collector) -> case SchedulerWallTime of undefined -> - erlang:system_flag(scheduler_wall_time,true), spawn(fun() -> flag_holder_proc(Collector) end), ok; _ -> @@ -348,10 +347,11 @@ etop_collect(Collector) -> end. flag_holder_proc(Collector) -> + erlang:system_flag(scheduler_wall_time,true), Ref = erlang:monitor(process,Collector), receive {'DOWN',Ref,_,_,_} -> - %% erlang:system_flag(scheduler_wall_time,false) + erlang:system_flag(scheduler_wall_time,false), ok end. diff --git a/lib/runtime_tools/src/runtime_tools.app.src b/lib/runtime_tools/src/runtime_tools.app.src index 449532e5c4..09a9b447c2 100644 --- a/lib/runtime_tools/src/runtime_tools.app.src +++ b/lib/runtime_tools/src/runtime_tools.app.src @@ -23,6 +23,7 @@ {modules, [appmon_info, dbg,observer_backend,runtime_tools, runtime_tools_sup,erts_alloc_config, ttb_autostart,dyntrace,system_information, + scheduler, msacc]}, {registered, [runtime_tools_sup]}, {applications, [kernel, stdlib]}, diff --git a/lib/runtime_tools/src/scheduler.erl b/lib/runtime_tools/src/scheduler.erl new file mode 100644 index 0000000000..c896b671ac --- /dev/null +++ b/lib/runtime_tools/src/scheduler.erl @@ -0,0 +1,152 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2018. 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% +%% + +%% @doc Utility functions for easier measurement of scheduler utilization +%% using erlang:statistics(scheduler_wall_time). + +-module(scheduler). + +-export([sample/0, + sample_all/0, + utilization/1, + utilization/2]). + +-export_type([sched_sample/0]). + + +-opaque sched_sample() :: + {scheduler_wall_time | scheduler_wall_time_all, + [{sched_type(), sched_id(), ActiveTime::integer(), TotalTime::integer()}]}. + +-type sched_type() :: normal | cpu | io. + +-type sched_id() :: integer(). + +-spec sample() -> sched_sample(). +sample() -> + sample(scheduler_wall_time). + +-spec sample_all() -> sched_sample(). +sample_all() -> + sample(scheduler_wall_time_all). + +sample(Stats) -> + case erlang:statistics(Stats) of + undefined -> + erlang:system_flag(scheduler_wall_time, true), + sample(Stats); + + List -> + Sorted = lists:sort(List), + Tagged = lists:map(fun({I, A, T}) -> {sched_tag(I), I, A, T} end, + Sorted), + {Stats, Tagged} + end. + +-type sched_util_result() :: + [{sched_type(), sched_id(), float(), string()} | + {total, float(), string()} | + {weighted, float(), string()}]. + +-spec utilization(Seconds) -> sched_util_result() when + Seconds :: pos_integer(); + (Sample) -> sched_util_result() when + Sample :: sched_sample(). +utilization(Seconds) when is_integer(Seconds), Seconds > 0 -> + OldFlag = erlang:system_flag(scheduler_wall_time, true), + T0 = sample(), + receive after Seconds*1000 -> ok end, + T1 = sample(), + case OldFlag of + false -> + erlang:system_flag(scheduler_wall_time, OldFlag); + true -> + ok + end, + utilization(T0,T1); + +utilization({Stats, _}=T0) when Stats =:= scheduler_wall_time; + Stats =:= scheduler_wall_time_all -> + utilization(T0, sample(Stats)). + +-spec utilization(Sample1, Sample2) -> sched_util_result() when + Sample1 :: sched_sample(), + Sample2 :: sched_sample(). +utilization({Stats, Ts0}, {Stats, Ts1}) -> + Diffs = lists:map(fun({{Tag, I, A0, T0}, {Tag, I, A1, T1}}) -> + {Tag, I, (A1 - A0), (T1 - T0)} + end, + lists:zip(Ts0,Ts1)), + + {Lst0, {A, T, N}} = lists:foldl(fun({Tag, I, Adiff, Tdiff}, {Lst, Acc}) -> + R = safe_div(Adiff, Tdiff), + {[{Tag, I, R, percent(R)} | Lst], + acc(Tag, Adiff, Tdiff, Acc)} + end, + {[], {0, 0, 0}}, + Diffs), + + Total = safe_div(A, T), + Lst1 = lists:reverse(Lst0), + Lst2 = case erlang:system_info(logical_processors_available) of + unknown -> Lst1; + LPA -> + Weighted = Total * (N / LPA), + [{weighted, Weighted, percent(Weighted)} | Lst1] + end, + [{total, Total, percent(Total)} | Lst2]; + +utilization({scheduler_wall_time, _}=T0, + {scheduler_wall_time_all, Ts1}) -> + utilization(T0, {scheduler_wall_time, remove_io(Ts1)}); + +utilization({scheduler_wall_time_all, Ts0}, + {scheduler_wall_time, _}=T1) -> + utilization({scheduler_wall_time, remove_io(Ts0)}, T1). + +%% Do not include dirty-io in totals +acc(io, _, _, Acc) -> + Acc; +acc(Tag, Adiff, Tdiff, {Asum, Tsum, N}) when Tag =:= normal; Tag =:= cpu -> + {Adiff+Asum, Tdiff+Tsum, N+1}. + + +remove_io(Ts) -> + lists:filter(fun({io,_,_,_}) -> false; + (_) -> true end, + Ts). + +safe_div(A, B) -> + if B == 0.0 -> 0.0; + true -> A / B + end. + +sched_tag(Nr) -> + Normal = erlang:system_info(schedulers), + Cpu = Normal + erlang:system_info(dirty_cpu_schedulers), + case Nr of + _ when Nr =< Normal -> normal; + _ when Nr =< Cpu -> cpu; + _ -> io + end. + + +percent(F) -> + float_to_list(F*100, [{decimals,1}]) ++ [$%]. diff --git a/lib/runtime_tools/src/system_information.erl b/lib/runtime_tools/src/system_information.erl index 92109c9a74..119d7cc3d4 100644 --- a/lib/runtime_tools/src/system_information.erl +++ b/lib/runtime_tools/src/system_information.erl @@ -75,43 +75,37 @@ load_report(file, File) -> load_report(data, from_file(File)); load_report(data, Report) -> ok = start_internal(), gen_server:call(?SERVER, {load_report, Report}, infinity). -report() -> [ - {init_arguments, init:get_arguments()}, - {code_paths, code:get_path()}, - {code, code()}, - {system_info, erlang_system_info()}, - {erts_compile_info, erlang:system_info(compile_info)}, - {beam_dynamic_libraries, get_dynamic_libraries()}, - {environment_erts, os_getenv_erts_specific()}, - {environment, [split_env(Env) || Env <- os:getenv()]}, - {sanity_check, sanity_check()} - ]. +report() -> + %% This is ugly but beats having to maintain two distinct implementations, + %% and we don't really care about memory use since it's internal and + %% undocumented. + {ok, Fd} = file:open([], [ram, read, write]), + to_fd(Fd), + {ok, _} = file:position(Fd, bof), + from_fd(Fd). -spec to_file(FileName) -> ok | {error, Reason} when FileName :: file:name_all(), Reason :: file:posix() | badarg | terminated | system_limit. to_file(File) -> - file:write_file(File, iolist_to_binary([ - io_lib:format("{system_information_version, ~p}.~n", [ - ?REPORT_FILE_VSN - ]), - io_lib:format("{system_information, ~p}.~n", [ - report() - ]) - ])). + case file:open(File, [raw, write, binary, delayed_write]) of + {ok, Fd} -> + try + to_fd(Fd) + after + file:close(Fd) + end; + {error, Reason} -> + {error, Reason} + end. from_file(File) -> - case file:consult(File) of - {ok, Data} -> - case get_value([system_information_version], Data) of - ?REPORT_FILE_VSN -> - get_value([system_information], Data); - Vsn -> - erlang:error({unknown_version, Vsn}) - end; - _ -> - erlang:error(bad_report_file) + {ok, Fd} = file:open(File, [raw, read]), + try + from_fd(Fd) + after + file:close(Fd) end. applications() -> applications([]). @@ -457,61 +451,151 @@ split_env([$=|Vs], Key) -> {lists:reverse(Key), Vs}; split_env([I|Vs], Key) -> split_env(Vs, [I|Key]); split_env([], KV) -> lists:reverse(KV). % should not happen. -%% get applications +from_fd(Fd) -> + try + [{system_information_version, "1.0"}, + {system_information, Data}] = consult_fd(Fd), + Data + catch + _:_ -> erlang:error(bad_report_file) + end. -code() -> - % order is important - get_code_from_paths(code:get_path()). +consult_fd(Fd) -> + consult_fd_1(Fd, [], {ok, []}). +consult_fd_1(Fd, Cont0, ReadResult) -> + Data = + case ReadResult of + {ok, Characters} -> Characters; + eof -> eof + end, + case erl_scan:tokens(Cont0, Data, 1) of + {done, {ok, Tokens, _}, Next} -> + {ok, Term} = erl_parse:parse_term(Tokens), + [Term | consult_fd_1(Fd, [], {ok, Next})]; + {more, Cont} -> + consult_fd_1(Fd, Cont, file:read(Fd, 1 bsl 20)); + {done, {eof, _}, eof} -> [] + end. -get_code_from_paths([]) -> []; -get_code_from_paths([Path|Paths]) -> - case is_application_path(Path) of - true -> - [{application, get_application_from_path(Path)}|get_code_from_paths(Paths)]; - false -> - [{code, [ - {path, Path}, - {modules, get_modules_from_path(Path)} - ]}|get_code_from_paths(Paths)] +%% +%% Dumps a system_information tuple to the given Fd, writing the term in chunks +%% to avoid eating too much memory on large systems. +%% + +to_fd(Fd) -> + EmitChunk = + fun(Format, Args) -> + ok = file:write(Fd, io_lib:format(Format, Args)) + end, + + EmitChunk("{system_information_version, ~p}.~n" + "{system_information,[" + "{init_arguments,~p}," + "{code_paths,~p},", + [?REPORT_FILE_VSN, + init:get_arguments(), + code:get_path()]), + + emit_code_info(EmitChunk), + + EmitChunk( "," %% Note the leading comma! + "{system_info,~p}," + "{erts_compile_info,~p}," + "{beam_dynamic_libraries,~p}," + "{environment_erts,~p}," + "{environment,~p}," + "{sanity_check,~p}" + "]}.~n", + [erlang_system_info(), + erlang:system_info(compile_info), + get_dynamic_libraries(), + os_getenv_erts_specific(), + [split_env(Env) || Env <- os:getenv()], + sanity_check()]). + +%% Emits all modules/applications in the *code path order* +emit_code_info(EmitChunk) -> + EmitChunk("{code, [", []), + comma_separated_foreach(EmitChunk, + fun(Path) -> + case is_application_path(Path) of + true -> emit_application_info(EmitChunk, Path); + false -> emit_code_path_info(EmitChunk, Path) + end + end, code:get_path()), + EmitChunk("]}", []). + +emit_application_info(EmitChunk, Path) -> + [Appfile|_] = filelib:wildcard(filename:join(Path, "*.app")), + case file:consult(Appfile) of + {ok, [{application, App, Info}]} -> + RtDeps = proplists:get_value(runtime_dependencies, Info, []), + Description = proplists:get_value(description, Info, []), + Version = proplists:get_value(vsn, Info, []), + + EmitChunk("{application, {~p,[" + "{description,~p}," + "{vsn,~p}," + "{path,~p}," + "{runtime_dependencies,~p},", + [App, Description, Version, Path, RtDeps]), + emit_module_info_from_path(EmitChunk, Path), + EmitChunk("]}}", []) end. +emit_code_path_info(EmitChunk, Path) -> + EmitChunk("{code, [" + "{path, ~p},", [Path]), + emit_module_info_from_path(EmitChunk, Path), + EmitChunk("]}", []). + +emit_module_info_from_path(EmitChunk, Path) -> + BeamFiles = filelib:wildcard(filename:join(Path, "*.beam")), + + EmitChunk("{modules, [", []), + comma_separated_foreach(EmitChunk, + fun(Beam) -> + emit_module_info(EmitChunk, Beam) + end, BeamFiles), + EmitChunk("]}", []). + +emit_module_info(EmitChunk, Beam) -> + %% FIXME: The next three calls load *all* significant chunks onto the heap, + %% which may cause us to run out of memory if there's a huge module in the + %% code path. + {ok,{Mod, Md5}} = beam_lib:md5(Beam), + + CompilerVersion = get_compiler_version(Beam), + Native = beam_is_native_compiled(Beam), + + Loaded = case code:is_loaded(Mod) of + false -> false; + _ -> true + end, + + EmitChunk("{~p,[" + "{loaded,~p}," + "{native,~p}," + "{compiler,~p}," + "{md5,~p}" + "]}", + [Mod, Loaded, Native, CompilerVersion, hexstring(Md5)]). + +comma_separated_foreach(_EmitChunk, _Fun, []) -> + ok; +comma_separated_foreach(_EmitChunk, Fun, [H]) -> + Fun(H); +comma_separated_foreach(EmitChunk, Fun, [H | T]) -> + Fun(H), + EmitChunk(",", []), + comma_separated_foreach(EmitChunk, Fun, T). + is_application_path(Path) -> case filelib:wildcard(filename:join(Path, "*.app")) of [] -> false; _ -> true end. -get_application_from_path(Path) -> - [Appfile|_] = filelib:wildcard(filename:join(Path, "*.app")), - case file:consult(Appfile) of - {ok, [{application, App, Info}]} -> - {App, [ - {description, proplists:get_value(description, Info, [])}, - {vsn, proplists:get_value(vsn, Info, [])}, - {path, Path}, - {runtime_dependencies, - proplists:get_value(runtime_dependencies, Info, [])}, - {modules, get_modules_from_path(Path)} - ]} - end. - -get_modules_from_path(Path) -> - [ - begin - {ok,{Mod, Md5}} = beam_lib:md5(Beam), - Loaded = case code:is_loaded(Mod) of - false -> false; - _ -> true - end, - {Mod, [ - {loaded, Loaded}, - {native, beam_is_native_compiled(Beam)}, - {compiler, get_compiler_version(Beam)}, - {md5, hexstring(Md5)} - ]} - end || Beam <- filelib:wildcard(filename:join(Path, "*.beam")) - ]. - hexstring(Bin) when is_binary(Bin) -> lists:flatten([io_lib:format("~2.16.0b", [V]) || <<V>> <= Bin]). diff --git a/lib/runtime_tools/test/Makefile b/lib/runtime_tools/test/Makefile index 61377ea09e..de37b2570d 100644 --- a/lib/runtime_tools/test/Makefile +++ b/lib/runtime_tools/test/Makefile @@ -9,6 +9,7 @@ MODULES = \ system_information_SUITE \ dbg_SUITE \ erts_alloc_config_SUITE \ + scheduler_SUITE \ msacc_SUITE ERL_FILES= $(MODULES:%=%.erl) diff --git a/lib/runtime_tools/test/scheduler_SUITE.erl b/lib/runtime_tools/test/scheduler_SUITE.erl new file mode 100644 index 0000000000..1c80253371 --- /dev/null +++ b/lib/runtime_tools/test/scheduler_SUITE.erl @@ -0,0 +1,104 @@ +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2018. 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(scheduler_SUITE). + +-export([suite/0, all/0]). + +%% Test cases +-export([basic/1]). + +all() -> [basic]. + + +suite() -> [{ct_hooks,[ts_install_cth]}]. + + +basic(_Config) -> + S1 = scheduler:sample(), + S2 = scheduler:sample_all(), + + check(scheduler:utilization(1)), + + check(scheduler:utilization(S1)), + check(scheduler:utilization(S2)), + check(scheduler:utilization(S1, scheduler:sample())), + check(scheduler:utilization(S2, scheduler:sample())), + + S3 = scheduler:sample_all(), + U13 = scheduler:utilization(S1, S3), + U13 = scheduler:utilization(S1, remove_io(S3)), + check(U13), + + U23all = scheduler:utilization(S2, S3), + check(U23all), + U23 = scheduler:utilization(S2, remove_io(S3)), + U23 = scheduler:utilization(remove_io(S2), S3), + U23 = remove_io(U23all), + check(U23), + + ok. + + +check([{total, Tf, Ts} | List]=U) -> + io:format("\nU = ~p\n", [U]), + check_values(Tf, Ts, true), + + SchdList = case hd(List) of + {weighted, Wf, Ws} -> + check_values(Wf, Ws, false), + tl(List); + _ -> + unknown = erlang:system_info(logical_processors_available), + List + end, + + lists:foreach(fun({Type, Id, F, S}) when ((Type =:= normal) or (Type =:= cpu) or (Type =:= io)), + is_integer(Id) -> + check_values(F, S, true) + end, + SchdList), + ok. + +check_values(F, S, Max100) -> + true = is_float(F), + true = F >= 0.0, + + $% = lists:last(S), + Sf = list_to_float(lists:droplast(S)), + true = Sf >= 0.0, + true = case Max100 of + true -> + true = F =< 1.0, + true = Sf =< 100.0; + false -> + true + end, + MaxDiff = 0.055555555555555555, %% change to 0.05 when float_to_list/2 is fixed + true = abs(F*100 - Sf) =< MaxDiff, + ok. + + +remove_io({scheduler_wall_time_all,Lst}) -> + {scheduler_wall_time, remove_io(Lst)}; +remove_io(Lst) -> + lists:filter(fun({io,_,_,_}) -> false; + (_) -> true end, + Lst). diff --git a/lib/runtime_tools/vsn.mk b/lib/runtime_tools/vsn.mk index d8a4ede136..872bd5db1d 100644 --- a/lib/runtime_tools/vsn.mk +++ b/lib/runtime_tools/vsn.mk @@ -1 +1 @@ -RUNTIME_TOOLS_VSN = 1.12.2 +RUNTIME_TOOLS_VSN = 1.12.3 diff --git a/lib/sasl/doc/src/Makefile b/lib/sasl/doc/src/Makefile index 76746e44e7..baf563ca62 100644 --- a/lib/sasl/doc/src/Makefile +++ b/lib/sasl/doc/src/Makefile @@ -47,8 +47,7 @@ XML_REF6_FILES = sasl_app.xml XML_PART_FILES = part.xml XML_CHAPTER_FILES = sasl_intro.xml \ error_logging.xml \ - notes.xml \ - notes_history.xml + notes.xml BOOK_FILES = book.xml diff --git a/lib/sasl/doc/src/notes.xml b/lib/sasl/doc/src/notes.xml index b144122c4b..e532c3cd6f 100644 --- a/lib/sasl/doc/src/notes.xml +++ b/lib/sasl/doc/src/notes.xml @@ -31,6 +31,26 @@ </header> <p>This document describes the changes made to the SASL application.</p> +<section><title>SASL 3.1.1</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + The Report Browser, rb, could earlier not handle reports + that were not lists, for example generated by + <c>error_logger:info_report({some, tuple})</c>. This term + is allowed as input to error_logger, but rb would state + that "A report on bad form was encountered". This is now + corrected.</p> + <p> + Own Id: OTP-13906 Aux Id: ERL-261 </p> + </item> + </list> + </section> + +</section> + <section><title>SASL 3.1</title> <section><title>Improvements and New Features</title> diff --git a/lib/sasl/src/systools_make.erl b/lib/sasl/src/systools_make.erl index 391b1fb5cc..9d960b7361 100644 --- a/lib/sasl/src/systools_make.erl +++ b/lib/sasl/src/systools_make.erl @@ -1501,7 +1501,7 @@ preloaded() -> [erl_prim_loader,erl_tracer,erlang, erts_code_purger,erts_dirty_process_code_checker, erts_internal,erts_literal_area_collector, - init,otp_ring0,prim_eval,prim_file, + init,otp_ring0,prim_buffer,prim_eval,prim_file, prim_inet,prim_zip,zlib]. %%______________________________________________________________________ diff --git a/lib/sasl/test/release_handler_SUITE.erl b/lib/sasl/test/release_handler_SUITE.erl index 63b48e7a4e..824820c214 100644 --- a/lib/sasl/test/release_handler_SUITE.erl +++ b/lib/sasl/test/release_handler_SUITE.erl @@ -22,7 +22,8 @@ -include_lib("common_test/include/ct.hrl"). -include("test_lib.hrl"). --compile(export_all). +-compile([export_all, nowarn_export_all]). +-export([scheduler_wall_time/0, garbage_collect/0]). %% rpc'ed % Default timetrap timeout (set in init_per_testcase). %-define(default_timeout, ?t:minutes(40)). @@ -1085,8 +1086,9 @@ otp_9395_update_many_mods(Conf) when is_list(Conf) -> Rel2Dir = filename:dirname(Rel2), %% Start a slave node + PA = filename:dirname(code:which(?MODULE)), {ok, Node} = t_start_node(otp_9395_update_many_mods, Rel1, - filename:join(Rel1Dir,"sys.config")), + filename:join(Rel1Dir,"sys.config"), "-pa " ++ PA), %% Start a lot of processes on the new node, all with refs to each %% module that will be updated @@ -1109,8 +1111,8 @@ otp_9395_update_many_mods(Conf) when is_list(Conf) -> [RelVsn2, filename:join(Rel2Dir, "sys.config")]), %% First, install release directly and check how much time it takes - rpc:call(Node,erlang,garbage_collect,[]), - rpc:call(Node,erlang,system_flag,[scheduler_wall_time,true]), + rpc:call(Node,?MODULE,garbage_collect,[]), + SWTFlag0 = spawn_link(Node, ?MODULE, scheduler_wall_time, []), {TInst0,{ok, _, []}} = timer:tc(rpc,call,[Node, release_handler, install_release, [RelVsn2]]), SWT0 = rpc:call(Node,erlang,statistics,[scheduler_wall_time]), @@ -1135,9 +1137,9 @@ otp_9395_update_many_mods(Conf) when is_list(Conf) -> %% Finally install release after check and purge, and check that %% this install was faster than the first. - rpc:call(Node,erlang,system_flag,[scheduler_wall_time,false]), - rpc:call(Node,erlang,garbage_collect,[]), - rpc:call(Node,erlang,system_flag,[scheduler_wall_time,true]), + SWTFlag0 ! die, + rpc:call(Node,?MODULE,garbage_collect,[]), + _SWTFlag1 = spawn_link(Node, ?MODULE, scheduler_wall_time, []), {TInst2,{ok, _RelVsn1, []}} = timer:tc(rpc,call,[Node, release_handler, install_release, [RelVsn2]]), SWT2 = rpc:call(Node,erlang,statistics,[scheduler_wall_time]), @@ -1161,6 +1163,15 @@ otp_9395_update_many_mods(Conf) when is_list(Conf) -> ok. +scheduler_wall_time() -> + erlang:system_flag(scheduler_wall_time,true), + receive _Msg -> normal end. + +garbage_collect() -> + Pids = processes(), + [erlang:garbage_collect(Pid) || Pid <- Pids]. + + otp_9395_update_many_mods(cleanup,_Conf) -> stop_node(node_name(otp_9395_update_many_mods)). @@ -1190,8 +1201,9 @@ otp_9395_rm_many_mods(Conf) when is_list(Conf) -> Rel2Dir = filename:dirname(Rel2), %% Start a slave node + PA = filename:dirname(code:which(?MODULE)), {ok, Node} = t_start_node(otp_9395_rm_many_mods, Rel1, - filename:join(Rel1Dir,"sys.config")), + filename:join(Rel1Dir,"sys.config"), "-pa " ++ PA), %% Start a lot of processes on the new node, all with refs to each %% module that will be updated @@ -1214,8 +1226,8 @@ otp_9395_rm_many_mods(Conf) when is_list(Conf) -> [RelVsn2, filename:join(Rel2Dir, "sys.config")]), %% First, install release directly and check how much time it takes - rpc:call(Node,erlang,garbage_collect,[]), - rpc:call(Node,erlang,system_flag,[scheduler_wall_time,true]), + rpc:call(Node,?MODULE,garbage_collect,[]), + SWTFlag0 = spawn_link(Node, ?MODULE, scheduler_wall_time, []), {TInst0,{ok, _, []}} = timer:tc(rpc,call,[Node, release_handler, install_release, [RelVsn2]]), SWT0 = rpc:call(Node,erlang,statistics,[scheduler_wall_time]), @@ -1240,9 +1252,9 @@ otp_9395_rm_many_mods(Conf) when is_list(Conf) -> %% Finally install release after check and purge, and check that %% this install was faster than the first. - rpc:call(Node,erlang,system_flag,[scheduler_wall_time,false]), - rpc:call(Node,erlang,garbage_collect,[]), - rpc:call(Node,erlang,system_flag,[scheduler_wall_time,true]), + SWTFlag0 ! die, + rpc:call(Node,?MODULE,garbage_collect,[]), + _SWTFlag1 = spawn_link(Node, ?MODULE, scheduler_wall_time, []), {TInst2,{ok, _RelVsn1, []}} = timer:tc(rpc,call,[Node, release_handler, install_release, [RelVsn2]]), SWT2 = rpc:call(Node,erlang,statistics,[scheduler_wall_time]), @@ -1384,9 +1396,9 @@ upgrade_supervisor(Conf) when is_list(Conf) -> %% Check that the restart strategy and child spec is updated {status, _, {module, _}, [_, _, _, _, [_,_,{data,[{"State",State}]}|_]]} = rpc:call(Node,sys,get_status,[a_sup]), - {state,_,RestartStrategy,[Child],_,_,_,_,_,_,_} = State, + {state,_,RestartStrategy,{[a],Db},_,_,_,_,_,_,_} = State, one_for_all = RestartStrategy, % changed from one_for_one - {child,_,_,_,_,brutal_kill,_,_} = Child, % changed from timeout 2000 + {child,_,_,_,_,brutal_kill,_,_} = maps:get(a,Db), % changed from timeout 2000 ok. diff --git a/lib/sasl/vsn.mk b/lib/sasl/vsn.mk index e980a42688..2488197ec5 100644 --- a/lib/sasl/vsn.mk +++ b/lib/sasl/vsn.mk @@ -1 +1 @@ -SASL_VSN = 3.1 +SASL_VSN = 3.1.1 diff --git a/lib/snmp/doc/src/notes.xml b/lib/snmp/doc/src/notes.xml index 6bdcae5dd7..1b5f94ed07 100644 --- a/lib/snmp/doc/src/notes.xml +++ b/lib/snmp/doc/src/notes.xml @@ -34,7 +34,22 @@ </header> - <section><title>SNMP 5.2.8</title> + <section><title>SNMP 5.2.9</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + +<section><title>SNMP 5.2.8</title> <section><title>Fixed Bugs and Malfunctions</title> <list> diff --git a/lib/snmp/test/snmp_agent_test.erl b/lib/snmp/test/snmp_agent_test.erl index 3c1a6f2afd..2ed2c4580c 100644 --- a/lib/snmp/test/snmp_agent_test.erl +++ b/lib/snmp/test/snmp_agent_test.erl @@ -605,7 +605,12 @@ init_per_group(multiple_reqs_3 = GroupName, Config) -> init_per_group(test_multi_threaded = GroupName, Config) -> init_mt(snmp_test_lib:init_group_top_dir(GroupName, Config)); init_per_group(test_v3 = GroupName, Config) -> - init_v3(snmp_test_lib:init_group_top_dir(GroupName, Config)); + case snmp_test_lib:crypto_start() of + ok -> + init_v3(snmp_test_lib:init_group_top_dir(GroupName, Config)); + _ -> + {skip, "Crypto did not start"} + end; init_per_group(test_v1_v2 = GroupName, Config) -> init_v1_v2(snmp_test_lib:init_group_top_dir(GroupName, Config)); init_per_group(test_v2 = GroupName, Config) -> @@ -631,11 +636,26 @@ init_per_group(mib_storage_varm_dets = GroupName, Config) -> init_varm_mib_storage_dets( snmp_test_lib:init_group_top_dir(GroupName, Config)); init_per_group(mib_storage_size_check_mnesia = GroupName, Config) -> - init_size_check_msm(snmp_test_lib:init_group_top_dir(GroupName, Config)); + case snmp_test_lib:crypto_start() of + ok -> + init_size_check_msm(snmp_test_lib:init_group_top_dir(GroupName, Config)); + _ -> + {skip, "Crypto did not start"} + end; init_per_group(mib_storage_size_check_dets = GroupName, Config) -> - init_size_check_msd(snmp_test_lib:init_group_top_dir(GroupName, Config)); + case snmp_test_lib:crypto_start() of + ok -> + init_size_check_msm(snmp_test_lib:init_group_top_dir(GroupName, Config)); + _ -> + {skip, "Crypto did not start"} + end; init_per_group(mib_storage_size_check_ets = GroupName, Config) -> - init_size_check_mse(snmp_test_lib:init_group_top_dir(GroupName, Config)); + case snmp_test_lib:crypto_start() of + ok -> + init_size_check_msm(snmp_test_lib:init_group_top_dir(GroupName, Config)); + _ -> + {skip, "Crypto did not start"} + end; init_per_group(mib_storage_mnesia = GroupName, Config) -> init_mib_storage_mnesia(snmp_test_lib:init_group_top_dir(GroupName, Config)); diff --git a/lib/snmp/test/snmp_manager_test.erl b/lib/snmp/test/snmp_manager_test.erl index 4bfeb0f8d1..6ced55f0cc 100644 --- a/lib/snmp/test/snmp_manager_test.erl +++ b/lib/snmp/test/snmp_manager_test.erl @@ -156,16 +156,25 @@ init_per_suite(Config0) when is_list(Config0) -> ?DBG("init_per_suite -> entry with" "~n Config0: ~p", [Config0]), - Config1 = snmp_test_lib:init_suite_top_dir(?MODULE, Config0), - Config2 = snmp_test_lib:fix_data_dir(Config1), - - %% Mib-dirs - %% data_dir is trashed by the test-server / common-test - %% so there is no point in fixing it... - MibDir = snmp_test_lib:lookup(data_dir, Config2), - StdMibDir = filename:join([code:priv_dir(snmp), "mibs"]), - - [{mib_dir, MibDir}, {std_mib_dir, StdMibDir} | Config2]. + %% Preferably this test SUITE should be divided into groups + %% so that if crypto does not work only v3 tests that + %% need crypto will be skipped, but as this is only a + %% problem with one legacy test machine, we will procrastinate + %% until we have a more important reason to fix this. + case snmp_test_lib:crypto_start() of + ok -> + Config1 = snmp_test_lib:init_suite_top_dir(?MODULE, Config0), + Config2 = snmp_test_lib:fix_data_dir(Config1), + %% Mib-dirs + %% data_dir is trashed by the test-server / common-test + %% so there is no point in fixing it... + MibDir = snmp_test_lib:lookup(data_dir, Config2), + StdMibDir = filename:join([code:priv_dir(snmp), "mibs"]), + + [{mib_dir, MibDir}, {std_mib_dir, StdMibDir} | Config2]; + _ -> + {skip, "Crypto did not start"} + end. end_per_suite(Config) when is_list(Config) -> diff --git a/lib/snmp/test/snmp_to_snmpnet_SUITE.erl b/lib/snmp/test/snmp_to_snmpnet_SUITE.erl index 24c14d86ea..6a3466b6e4 100644 --- a/lib/snmp/test/snmp_to_snmpnet_SUITE.erl +++ b/lib/snmp/test/snmp_to_snmpnet_SUITE.erl @@ -88,8 +88,17 @@ groups() -> ]. init_per_suite(Config) -> - [{agent_port, ?AGENT_PORT}, {manager_port, ?MANAGER_PORT} | Config]. - + case re:run(os:cmd("snmpd -v"),"NET-SNMP", [{capture, first}]) of + nomatch -> + {skip, "snmpd is NOT NET-SNMP"}; + {match, _} -> + case re:run(os:cmd("snmpd -v"),"5.4|5.6.2.1", [{capture, first}]) of + nomatch -> + [{agent_port, ?AGENT_PORT}, {manager_port, ?MANAGER_PORT} | Config]; + {match, _} -> + {skip, "buggy snmpd"} + end + end. end_per_suite(_Config) -> ok. @@ -322,7 +331,7 @@ snmpget(Oid, Transport, Config) -> Args = ["-c", "public", net_snmp_version(Versions), - "-m", "", + "-m", ":", "-Cf", net_snmp_addr_str(Transport), oid_str(Oid)], @@ -353,11 +362,13 @@ start_snmpd(Community, SysDescr, Config) -> ["--rocommunity"++domain_suffix(Domain)++"=" ++Community++" "++inet_parse:ntoa(Ip) || {Domain, {Ip, _}} <- Targets], + SnmpdArgs = - ["-f", "-r", %"-Dverbose", - "-c", filename:join(DataDir, "snmpd.conf"), - "-C", "-Lo", - "-m", "", + ["-f", "-r", %"-Dverbose", + "-c", filename:join(DataDir, "snmpd.conf"), + "-C", + "-Lo", + "-m", ":", "--sysDescr="++SysDescr, "--agentXSocket=tcp:localhost:"++integer_to_list(Port)] ++ CommunityArgs diff --git a/lib/snmp/vsn.mk b/lib/snmp/vsn.mk index ef48608bda..c195f9f5d9 100644 --- a/lib/snmp/vsn.mk +++ b/lib/snmp/vsn.mk @@ -19,6 +19,6 @@ # %CopyrightEnd% APPLICATION = snmp -SNMP_VSN = 5.2.8 +SNMP_VSN = 5.2.9 PRE_VSN = APP_VSN = "$(APPLICATION)-$(SNMP_VSN)$(PRE_VSN)" diff --git a/lib/ssh/doc/src/Makefile b/lib/ssh/doc/src/Makefile index e066b787f3..f54f5e0708 100644 --- a/lib/ssh/doc/src/Makefile +++ b/lib/ssh/doc/src/Makefile @@ -52,9 +52,9 @@ XML_PART_FILES = \ usersguide.xml XML_CHAPTER_FILES = notes.xml \ introduction.xml \ - ssh_protocol.xml \ using_ssh.xml \ configure_algos.xml +# ssh_protocol.xml \ BOOK_FILES = book.xml diff --git a/lib/ssh/doc/src/notes.xml b/lib/ssh/doc/src/notes.xml index ef3e94a1e1..3a2f55a487 100644 --- a/lib/ssh/doc/src/notes.xml +++ b/lib/ssh/doc/src/notes.xml @@ -30,12 +30,96 @@ <file>notes.xml</file> </header> -<section><title>Ssh 4.6.1</title> +<section><title>Ssh 4.6.4</title> <section><title>Fixed Bugs and Malfunctions</title> <list> <item> <p> + Fix problem with OpenSSH 7.2 (and later) clients that has + used sha1 instead of sha2 for rsa-sha-256/512 user's + public keys.</p> + <p> + Own Id: OTP-14827 Aux Id: ERL-531 </p> + </item> + </list> + </section> + +</section> + +<section><title>Ssh 4.6.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Passphrase option for ecdsa public keys was missing.</p> + <p> + Own Id: OTP-14602</p> + </item> + </list> + </section> + + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + The host and user public key handling is hardened so that + a faulty plugin can't deliver a key of wrong type.</p> + <p> + Better checks in the server of the available hostkey's + types at start and at each accept.</p> + <p> + Better checks in the client of the available user public + key types at connect.</p> + <p> + Own Id: OTP-14676 Aux Id: ERIERL-52, OTP-14570 </p> + </item> + <item> + <p> + SSH can now fetch the host key from the private keys + stored in an Engine. See the crypto application for + details about Engines.</p> + <p> + Own Id: OTP-14757</p> + </item> + </list> + </section> + +</section> + +<section><title>Ssh 4.6.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Trailing white space was removed at end of the + hello-string. This caused interoperability problems with + some other ssh-implementations (e.g OpenSSH 7.3p1 on + Solaris 11)</p> + <p> + Own Id: OTP-14763 Aux Id: ERIERL-74 </p> + </item> + <item> + <p> + Fixes that tcp connections that was immediately closed + (SYN, SYNACK, ACK, RST) by a client could be left in a + zombie state.</p> + <p> + Own Id: OTP-14778 Aux Id: ERIERL-104 </p> + </item> + </list> + </section> + +</section> + +<section><title>Ssh 4.6.1</title> + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Fixed broken printout</p> <p> Own Id: OTP-14645</p> diff --git a/lib/ssh/doc/src/ssh_client_key_api.xml b/lib/ssh/doc/src/ssh_client_key_api.xml index a1cd9d4b02..98a1676ca4 100644 --- a/lib/ssh/doc/src/ssh_client_key_api.xml +++ b/lib/ssh/doc/src/ssh_client_key_api.xml @@ -56,11 +56,17 @@ <tag><c>string() =</c></tag> <item><p><c>[byte()]</c></p></item> <tag><c>public_key() =</c></tag> - <item><p><c>#'RSAPublicKey'{}| {integer(), #'Dss-Parms'{}}| term()</c></p></item> + <item><p><c>#'RSAPublicKey'{} + | {integer(),#'Dss-Parms'{}} + | {#'ECPoint'{},{namedCurve,Curve::string()}}</c></p></item> <tag><c>private_key() =</c></tag> - <item><p><c>#'RSAPrivateKey'{} | #'DSAPrivateKey'{} | term()</c></p></item> + <item><p><c>#'RSAPrivateKey'{} + | #'DSAPrivateKey'{} + | #'ECPrivateKey'{}</c></p></item> <tag><c>public_key_algorithm() =</c></tag> - <item><p><c>'ssh-rsa'| 'ssh-dss' | atom()</c></p></item> + <item><p><c>'ssh-rsa' | 'ssh-dss' + | 'rsa-sha2-256' | 'rsa-sha2-384' | 'rsa-sha2-512' + | 'ecdsa-sha2-nistp256' | 'ecdsa-sha2-nistp384' | 'ecdsa-sha2-nistp521' </c></p></item> </taglist> </section> @@ -73,10 +79,11 @@ <d>Description of the host that owns the <c>PublicKey</c>.</d> <v>Key = public_key()</v> - <d>Normally an RSA or DSA public key, but handling of other public keys can be added.</d> + <d>Normally an RSA, DSA or ECDSA public key, but handling of other public keys can be added.</d> <v>ConnectOptions = proplists:proplist()</v> - <d>Options provided to <seealso marker="ssh#connect-3">ssh:connect/[3,4]</seealso></d> + <d>Options provided to <seealso marker="ssh#connect-3">ssh:connect/[3,4]</seealso>. The option list given in + the <c>key_cb</c> option is available with the key <c>key_cb_private</c>.</d> <v>Reason = term().</v> </type> <desc> @@ -89,17 +96,17 @@ <fsummary>Checks if a host key is trusted.</fsummary> <type> <v>Key = public_key() </v> - <d>Normally an RSA or DSA public key, but handling of other public keys can be added.</d> + <d>Normally an RSA, DSA or ECDSA public key, but handling of other public keys can be added.</d> <v>Host = string()</v> <d>Description of the host.</d> <v>Algorithm = public_key_algorithm()</v> - <d>Host key algorithm. Is to support <c>'ssh-rsa'| 'ssh-dss'</c>, but more algorithms - can be handled.</d> + <d>Host key algorithm.</d> <v>ConnectOptions = proplists:proplist() </v> - <d>Options provided to <seealso marker="ssh#connect-3">ssh:connect/[3,4]</seealso>.</d> + <d>Options provided to <seealso marker="ssh#connect-3">ssh:connect/[3,4]</seealso>. The option list given in + the <c>key_cb</c> option is available with the key <c>key_cb_private</c>.</d> <v>Result = boolean()</v> </type> @@ -110,15 +117,15 @@ <func> <name>Module:user_key(Algorithm, ConnectOptions) -> - {ok, PrivateKey} | {error, Reason}</name> + {ok, PrivateKey} | {error, Reason}</name> <fsummary>Fetches the users <em>public key</em> matching the <c>Algorithm</c>.</fsummary> <type> <v>Algorithm = public_key_algorithm()</v> - <d>Host key algorithm. Is to support <c>'ssh-rsa'| 'ssh-dss'</c> but more algorithms - can be handled.</d> + <d>Host key algorithm.</d> <v>ConnectOptions = proplists:proplist()</v> - <d>Options provided to <seealso marker="ssh#connect-3">ssh:connect/[3,4]</seealso></d> + <d>Options provided to <seealso marker="ssh#connect-3">ssh:connect/[3,4]</seealso>. The option list given in + the <c>key_cb</c> option is available with the key <c>key_cb_private</c>.</d> <v>PrivateKey = private_key()</v> <d>Private key of the user matching the <c>Algorithm</c>.</d> diff --git a/lib/ssh/doc/src/ssh_server_key_api.xml b/lib/ssh/doc/src/ssh_server_key_api.xml index a0694ca8d9..c6808b95d1 100644 --- a/lib/ssh/doc/src/ssh_server_key_api.xml +++ b/lib/ssh/doc/src/ssh_server_key_api.xml @@ -57,11 +57,17 @@ <tag><c>string() =</c></tag> <item><p><c>[byte()]</c></p></item> <tag><c>public_key() =</c></tag> - <item><p><c>#'RSAPublicKey'{}| {integer(), #'Dss-Parms'{}}| term()</c></p></item> + <item><p><c>#'RSAPublicKey'{} + | {integer(),#'Dss-Parms'{}} + | {#'ECPoint'{},{namedCurve,Curve::string()}}</c></p></item> <tag><c>private_key() =</c></tag> - <item><p><c>#'RSAPrivateKey'{} | #'DSAPrivateKey'{} | term()</c></p></item> + <item><p><c>#'RSAPrivateKey'{} + | #'DSAPrivateKey'{} + | #'ECPrivateKey'{}</c></p></item> <tag><c>public_key_algorithm() =</c></tag> - <item><p><c>'ssh-rsa'| 'ssh-dss' | atom()</c></p></item> + <item><p><c>'ssh-rsa' | 'ssh-dss' + | 'rsa-sha2-256' | 'rsa-sha2-384' | 'rsa-sha2-512' + | 'ecdsa-sha2-nistp256' | 'ecdsa-sha2-nistp384' | 'ecdsa-sha2-nistp521' </c></p></item> </taglist> </section> @@ -72,12 +78,13 @@ <fsummary>Fetches the host’s private key.</fsummary> <type> <v>Algorithm = public_key_algorithm()</v> - <d>Host key algorithm. Is to support <c>'ssh-rsa' | 'ssh-dss'</c>, but more algorithms - can be handled.</d> + <d>Host key algorithm.</d> <v>DaemonOptions = proplists:proplist()</v> - <d>Options provided to <seealso marker="ssh#daemon-2">ssh:daemon/[2,3]</seealso>.</d> - <v>Key = private_key()</v> - <d>Private key of the host matching the <c>Algorithm</c>.</d> + <d>Options provided to <seealso marker="ssh#daemon-2">ssh:daemon/[2,3]</seealso>. The option list given in + the <c>key_cb</c> option is available with the key <c>key_cb_private</c>.</d> + <v>Key = private_key() | crypto:engine_key_ref()</v> + <d>Private key of the host matching the <c>Algorithm</c>. + It may be a reference to a 'ssh-rsa', rsa-sha2-* or 'ssh-dss' (NOT ecdsa) key stored in a loaded Engine.</d> <v>Reason = term()</v> </type> <desc> @@ -90,11 +97,12 @@ <fsummary>Checks if the user key is authorized.</fsummary> <type> <v>Key = public_key()</v> - <d>Normally an RSA or DSA public key, but handling of other public keys can be added</d> + <d>Normally an RSA, DSA or ECDSA public key, but handling of other public keys can be added</d> <v>User = string()</v> <d>User owning the public key.</d> <v>DaemonOptions = proplists:proplist()</v> - <d>Options provided to <seealso marker="ssh#daemon-2">ssh:daemon/[2,3]</seealso>.</d> + <d>Options provided to <seealso marker="ssh#daemon-2">ssh:daemon/[2,3]</seealso>. The option list given in + the <c>key_cb</c> option is available with the key <c>key_cb_private</c>.</d> <v>Result = boolean()</v> </type> <desc> diff --git a/lib/ssh/src/ssh.app.src b/lib/ssh/src/ssh.app.src index 974292fde1..4a22322333 100644 --- a/lib/ssh/src/ssh.app.src +++ b/lib/ssh/src/ssh.app.src @@ -42,10 +42,10 @@ {env, []}, {mod, {ssh_app, []}}, {runtime_dependencies, [ - "crypto-3.7.3", + "crypto-4.2", "erts-6.0", "kernel-3.0", - "public_key-1.4", + "public_key-1.5.2", "stdlib-3.3" ]}]}. diff --git a/lib/ssh/src/ssh.erl b/lib/ssh/src/ssh.erl index 1a5d48baca..032d87bdad 100644 --- a/lib/ssh/src/ssh.erl +++ b/lib/ssh/src/ssh.erl @@ -188,6 +188,7 @@ daemon(Port) -> daemon(Socket, UserOptions) when is_port(Socket) -> try #{} = Options = ssh_options:handle_options(server, UserOptions), + case valid_socket_to_use(Socket, ?GET_OPT(transport,Options)) of ok -> {ok, {IP,Port}} = inet:sockname(Socket), @@ -461,6 +462,9 @@ open_listen_socket(_Host0, Port0, Options0) -> %%%---------------------------------------------------------------- finalize_start(Host, Port, Profile, Options0, F) -> try + %% throws error:Error if no usable hostkey is found + ssh_connection_handler:available_hkey_algorithms(server, Options0), + sshd_sup:start_child(Host, Port, Profile, Options0) of {error, {already_started, _}} -> @@ -470,6 +474,8 @@ finalize_start(Host, Port, Profile, Options0, F) -> Result = {ok,_} -> F(Options0, Result) catch + error:{shutdown,Err} -> + {error,Err}; exit:{noproc, _} -> {error, ssh_not_started} end. diff --git a/lib/ssh/src/ssh.hrl b/lib/ssh/src/ssh.hrl index d6d412db43..3dee1c5521 100644 --- a/lib/ssh/src/ssh.hrl +++ b/lib/ssh/src/ssh.hrl @@ -63,8 +63,8 @@ -define(uint16(X), << ?UINT16(X) >> ). -define(uint32(X), << ?UINT32(X) >> ). -define(uint64(X), << ?UINT64(X) >> ). --define(string(X), << ?STRING(list_to_binary(X)) >> ). -define(string_utf8(X), << ?STRING(unicode:characters_to_binary(X)) >> ). +-define(string(X), ?string_utf8(X)). -define(binary(X), << ?STRING(X) >>). %% Cipher details diff --git a/lib/ssh/src/ssh_auth.erl b/lib/ssh/src/ssh_auth.erl index ac64a7bf14..03d264745b 100644 --- a/lib/ssh/src/ssh_auth.erl +++ b/lib/ssh/src/ssh_auth.erl @@ -145,14 +145,17 @@ get_public_key(SigAlg, #ssh{opts = Opts}) -> case KeyCb:user_key(KeyAlg, [{key_cb_private,KeyCbOpts}|UserOpts]) of {ok, PrivKey} -> try + %% Check the key - the KeyCb may be a buggy plugin + true = ssh_transport:valid_key_sha_alg(PrivKey, KeyAlg), Key = ssh_transport:extract_public_key(PrivKey), public_key:ssh_encode(Key, ssh2_pubkey) of PubKeyBlob -> {ok,{PrivKey,PubKeyBlob}} catch _:_ -> - not_ok + not_ok end; + _Error -> not_ok end. @@ -301,11 +304,10 @@ handle_userauth_request(#ssh_msg_userauth_request{user = User, SigWLen/binary>> }, SessionId, - #ssh{opts = Opts, - userauth_supported_methods = Methods} = Ssh) -> + #ssh{userauth_supported_methods = Methods} = Ssh) -> case verify_sig(SessionId, User, "ssh-connection", - BAlg, KeyBlob, SigWLen, Opts) of + BAlg, KeyBlob, SigWLen, Ssh) of true -> {authorized, User, ssh_transport:ssh_packet( @@ -515,7 +517,7 @@ pre_verify_sig(User, KeyBlob, Opts) -> false end. -verify_sig(SessionId, User, Service, AlgBin, KeyBlob, SigWLen, Opts) -> +verify_sig(SessionId, User, Service, AlgBin, KeyBlob, SigWLen, #ssh{opts = Opts} = Ssh) -> try Alg = binary_to_list(AlgBin), {KeyCb,KeyCbOpts} = ?GET_OPT(key_cb, Opts), @@ -526,7 +528,7 @@ verify_sig(SessionId, User, Service, AlgBin, KeyBlob, SigWLen, Opts) -> <<?UINT32(AlgSigLen), AlgSig:AlgSigLen/binary>> = SigWLen, <<?UINT32(AlgLen), _Alg:AlgLen/binary, ?UINT32(SigLen), Sig:SigLen/binary>> = AlgSig, - ssh_transport:verify(PlainText, ssh_transport:sha(Alg), Sig, Key) + ssh_transport:verify(PlainText, ssh_transport:sha(Alg), Sig, Key, Ssh) catch _:_ -> false diff --git a/lib/ssh/src/ssh_connection_handler.erl b/lib/ssh/src/ssh_connection_handler.erl index 4158a52a27..0ca960ef96 100644 --- a/lib/ssh/src/ssh_connection_handler.erl +++ b/lib/ssh/src/ssh_connection_handler.erl @@ -46,6 +46,7 @@ %%% Internal application API -export([start_connection/4, + available_hkey_algorithms/2, open_channel/6, request/6, request/7, reply_request/3, @@ -324,23 +325,32 @@ renegotiate_data(ConnectionHandler) -> %% Internal process state %%==================================================================== -record(data, { - starter :: pid(), + starter :: pid() + | undefined, auth_user :: string() | undefined, connection_state :: #connection{}, - latest_channel_id = 0 :: non_neg_integer(), + latest_channel_id = 0 :: non_neg_integer() + | undefined, 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{}, - socket :: inet:socket(), - decrypted_data_buffer = <<>> :: binary(), - encrypted_data_buffer = <<>> :: binary(), + transport_protocol :: atom() + | undefined, % ex: tcp + transport_cb :: atom() + | undefined, % ex: gen_tcp + transport_close_tag :: atom() + | undefined, % ex: tcp_closed + ssh_params :: #ssh{} + | undefined, + socket :: inet:socket() + | undefined, + decrypted_data_buffer = <<>> :: binary() + | undefined, + encrypted_data_buffer = <<>> :: binary() + | undefined, undecrypted_packet_length :: undefined | non_neg_integer(), key_exchange_init_msg :: #ssh_msg_kexinit{} | undefined, @@ -369,16 +379,17 @@ init_connection_handler(Role, Socket, Opts) -> StartState, D); - {stop, enotconn} -> - %% Handles the abnormal sequence: - %% SYN-> - %% <-SYNACK - %% ACK-> - %% RST-> - exit({shutdown, "TCP connection to server was prematurely closed by the client"}); - - {stop, OtherError} -> - exit({shutdown, {init,OtherError}}) + {stop, Error} -> + Sups = ?GET_INTERNAL_OPT(supervisors, Opts), + C = #connection{system_supervisor = proplists:get_value(system_sup, Sups), + sub_system_supervisor = proplists:get_value(subsystem_sup, Sups), + connection_supervisor = proplists:get_value(connection_sup, Sups) + }, + gen_statem:enter_loop(?MODULE, + [], + {init_error,Error}, + #data{connection_state=C, + socket=Socket}) end. @@ -432,13 +443,12 @@ init_ssh_record(Role, Socket, Opts) -> init_ssh_record(Role, Socket, PeerAddr, Opts). init_ssh_record(Role, _Socket, PeerAddr, Opts) -> - KeyCb = ?GET_OPT(key_cb, Opts), AuthMethods = ?GET_OPT(auth_methods, Opts), S0 = #ssh{role = Role, - key_cb = KeyCb, + key_cb = ?GET_OPT(key_cb, Opts), opts = Opts, userauth_supported_methods = AuthMethods, - available_host_keys = supported_host_keys(Role, KeyCb, Opts), + available_host_keys = available_hkey_algorithms(Role, Opts), random_length_padding = ?GET_OPT(max_random_length_padding, Opts) }, @@ -531,6 +541,21 @@ renegotiation(_) -> false. callback_mode() -> handle_event_function. + +handle_event(_, _Event, {init_error,Error}, _) -> + case Error of + 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, 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) -> @@ -1544,44 +1569,42 @@ peer_role(client) -> server; peer_role(server) -> client. %%-------------------------------------------------------------------- -supported_host_keys(client, _, Options) -> - try - find_sup_hkeys(Options) - of - [] -> +available_hkey_algorithms(Role, Options) -> + KeyCb = ?GET_OPT(key_cb, Options), + case [A || A <- available_hkey_algos(Options), + (Role==client) orelse available_host_key(KeyCb, A, Options) + ] of + + [] when Role==client -> error({shutdown, "No public key algs"}); - Algs -> - [atom_to_list(A) || A<-Algs] - catch - exit:Reason -> - error({shutdown, Reason}) - end; -supported_host_keys(server, KeyCb, Options) -> - [atom_to_list(A) || A <- find_sup_hkeys(Options), - available_host_key(KeyCb, A, Options) - ]. + [] when Role==server -> + error({shutdown, "No host key available"}); -find_sup_hkeys(Options) -> - case proplists:get_value(public_key, - ?GET_OPT(preferred_algorithms,Options) - ) - of - undefined -> - ssh_transport:default_algorithms(public_key); - L -> - NonSupported = L--ssh_transport:supported_algorithms(public_key), - L -- NonSupported + Algs -> + [atom_to_list(A) || A<-Algs] end. +available_hkey_algos(Options) -> + SupAlgos = ssh_transport:supported_algorithms(public_key), + HKeys = proplists:get_value(public_key, + ?GET_OPT(preferred_algorithms,Options) + ), + NonSupported = HKeys -- SupAlgos, + AvailableAndSupported = HKeys -- NonSupported, + AvailableAndSupported. + %% Alg :: atom() available_host_key({KeyCb,KeyCbOpts}, Alg, Opts) -> UserOpts = ?GET_OPT(user_options, Opts), case KeyCb:host_key(Alg, [{key_cb_private,KeyCbOpts}|UserOpts]) of - {ok,_} -> true; - _ -> false + {ok,Key} -> + %% Check the key - the KeyCb may be a buggy plugin + ssh_transport:valid_key_sha_alg(Key, Alg); + _ -> + false end. diff --git a/lib/ssh/src/ssh_dbg.erl b/lib/ssh/src/ssh_dbg.erl index af9ad52d68..eb2c2848f3 100644 --- a/lib/ssh/src/ssh_dbg.erl +++ b/lib/ssh/src/ssh_dbg.erl @@ -146,7 +146,26 @@ msg_formater(msg, {trace_ts,_Pid,return_from,{ssh_message,encode,1},_Res,_TS}, D msg_formater(msg, {trace_ts,_Pid,call,{ssh_message,decode,_},_TS}, D) -> D; msg_formater(msg, {trace_ts,Pid,return_from,{ssh_message,decode,1},Msg,TS}, D) -> - fmt("~n~s ~p RECV ~s~n", [ts(TS),Pid,wr_record(shrink_bin(Msg))], D); + Extra = + case Msg of + #ssh_msg_userauth_info_request{data = D0} -> + try ssh_message:decode_keyboard_interactive_prompts(D0, []) + of + Acc -> + io_lib:format(" -- decoded data:~n", []) ++ + element(1, + lists:mapfoldl( + fun({Prompt,Echo}, N) -> + {io_lib:format(" prompt[~p]: \"~s\" (echo=~p)~n",[N,Prompt,Echo]), N+1} + end, 1, Acc)) + catch + _:_ -> + "" + end; + _ -> + "" + end, + fmt("~n~s ~p RECV ~s~s~n", [ts(TS),Pid,wr_record(shrink_bin(Msg)),Extra], D); msg_formater(_auth, {trace_ts,Pid,return_from,{ssh_message,decode,1},#ssh_msg_userauth_failure{authentications=As},TS}, D) -> fmt("~n~s ~p Client login FAILURE. Try ~s~n", [ts(TS),Pid,As], D); @@ -232,21 +251,22 @@ msg_formater(_, {trace_ts,Pid,return_from, {ssh_transport,known_host_key,3}, Res end; msg_formater(_, {trace_ts,Pid,call,{ssh_auth,publickey_msg,[[SigAlg,#ssh{user=User}]]},TS}, D) -> - fmt("~n~s ~p Client will try to login user ~p with public key algorithm ~p~n", [ts(TS),Pid,User,SigAlg], D); + fmt("~n~s ~p Client will try to login user ~p with method: public key algorithm ~p~n", [ts(TS),Pid,User,SigAlg], D); msg_formater(_, {trace_ts,Pid,return_from,{ssh_auth,publickey_msg,1},{not_ok,#ssh{user=User}},TS}, D) -> - fmt("~s ~p User ~p can't login with that kind of public key~n", [ts(TS),Pid,User], D); -msg_formater(_, {trace_ts,Pid,return_from,{ssh_auth,publickey_msg,1},{_,#ssh{user=User}},TS}, D) -> - fmt("~s ~p User ~p logged in~n", [ts(TS),Pid,User], D); + fmt("~s ~p User ~p can't use that kind of public key~n", [ts(TS),Pid,User], D); +msg_formater(_, {trace_ts,_Pid,return_from,{ssh_auth,publickey_msg,1},_,_TS}, D) -> D; msg_formater(_, {trace_ts,Pid,call,{ssh_auth,password_msg,[[#ssh{user=User}]]},TS}, D) -> - fmt("~n~s ~p Client will try to login user ~p with password~n", [ts(TS),Pid,User], D); + fmt("~n~s ~p Client will try to login user ~p with method: password~n", [ts(TS),Pid,User], D); msg_formater(_, {trace_ts,Pid,return_from,{ssh_auth,password_msg,1},{not_ok,#ssh{user=User}},TS}, D) -> - fmt("~s ~p User ~p can't login with password~n", [ts(TS),Pid,User], D); + fmt("~s ~p User ~p can't use method password as login method~n", [ts(TS),Pid,User], D); +msg_formater(_, {trace_ts,_Pid,return_from,{ssh_auth,password_msg,1},_Result,_TS}, D) -> D; msg_formater(_, {trace_ts,Pid,call,{ssh_auth,keyboard_interactive_msg,[[#ssh{user=User}]]},TS}, D) -> - fmt("~n~s ~p Client will try to login user ~p with password~n", [ts(TS),Pid,User], D); + fmt("~n~s ~p Client will try to login user ~p with method: keyboard-interactive~n", [ts(TS),Pid,User], D); msg_formater(_, {trace_ts,Pid,return_from,{ssh_auth,keyboard_interactive_msg,1},{not_ok,#ssh{user=User}},TS}, D) -> - fmt("~s ~p User ~p can't login with keyboard_interactive password~n", [ts(TS),Pid,User], D); + fmt("~s ~p User ~p can't use method keyboard-interactive as login method~n", [ts(TS),Pid,User], D); +msg_formater(_, {trace_ts,_Pid,return_from,{ssh_auth,keyboard_interactive_msg,1},_Result,_TS}, D) -> D; msg_formater(msg, {trace_ts,Pid,send,{tcp,Sock,Bytes},Pid,TS}, D) -> fmt("~n~s ~p TCP SEND on ~p~n ~p~n", [ts(TS),Pid,Sock, shrink_bin(Bytes)], D); diff --git a/lib/ssh/src/ssh_transport.erl b/lib/ssh/src/ssh_transport.erl index e92c727559..ad9efc4755 100644 --- a/lib/ssh/src/ssh_transport.erl +++ b/lib/ssh/src/ssh_transport.erl @@ -51,10 +51,10 @@ extract_public_key/1, ssh_packet/2, pack/2, valid_key_sha_alg/2, - sha/1, sign/3, verify/4]). + sha/1, sign/3, verify/5]). %%% For test suites --export([pack/3]). +-export([pack/3, adjust_algs_for_peer_version/2]). -export([decompress/2, decrypt_blocks/3, is_valid_mac/3 ]). % FIXME: remove -define(Estring(X), ?STRING((if is_binary(X) -> X; @@ -795,8 +795,14 @@ get_host_key(SSH, SignAlg) -> #ssh{key_cb = {KeyCb,KeyCbOpts}, opts = Opts} = SSH, UserOpts = ?GET_OPT(user_options, Opts), case KeyCb:host_key(SignAlg, [{key_cb_private,KeyCbOpts}|UserOpts]) of - {ok, PrivHostKey} -> PrivHostKey; - Result -> exit({error, {Result, unsupported_key_type}}) + {ok, PrivHostKey} -> + %% Check the key - the KeyCb may be a buggy plugin + case valid_key_sha_alg(PrivHostKey, SignAlg) of + true -> PrivHostKey; + false -> exit({error, bad_hostkey}) + end; + Result -> + exit({error, {Result, unsupported_key_type}}) end. extract_public_key(#'RSAPrivateKey'{modulus = N, publicExponent = E}) -> @@ -805,13 +811,21 @@ extract_public_key(#'DSAPrivateKey'{y = Y, p = P, q = Q, g = G}) -> {Y, #'Dss-Parms'{p=P, q=Q, g=G}}; extract_public_key(#'ECPrivateKey'{parameters = {namedCurve,OID}, publicKey = Q}) -> - {#'ECPoint'{point=Q}, {namedCurve,OID}}. + {#'ECPoint'{point=Q}, {namedCurve,OID}}; +extract_public_key(#{engine:=_, key_id:=_, algorithm:=Alg} = M) -> + case {Alg, crypto:privkey_to_pubkey(Alg, M)} of + {rsa, [E,N]} -> + #'RSAPublicKey'{modulus = N, publicExponent = E}; + {dss, [P,Q,G,Y]} -> + {Y, #'Dss-Parms'{p=P, q=Q, g=G}} + end. + verify_host_key(#ssh{algorithms=Alg}=SSH, PublicKey, Digest, {AlgStr,Signature}) -> case atom_to_list(Alg#alg.hkey) of AlgStr -> - case verify(Digest, sha(Alg#alg.hkey), Signature, PublicKey) of + case verify(Digest, sha(Alg#alg.hkey), Signature, PublicKey, SSH) of false -> {error, bad_signature}; true -> @@ -1255,10 +1269,12 @@ payload(<<PacketLen:32, PaddingLen:8, PayloadAndPadding/binary>>) -> <<Payload:PayloadLen/binary, _/binary>> = PayloadAndPadding, Payload. +sign(SigData, HashAlg, #{algorithm:=dss} = Key) -> + mk_dss_sig(crypto:sign(dss, HashAlg, SigData, Key)); +sign(SigData, HashAlg, #{algorithm:=SigAlg} = Key) -> + crypto:sign(SigAlg, HashAlg, SigData, Key); sign(SigData, HashAlg, #'DSAPrivateKey'{} = Key) -> - DerSignature = public_key:sign(SigData, HashAlg, Key), - #'Dss-Sig-Value'{r = R, s = S} = public_key:der_decode('Dss-Sig-Value', DerSignature), - <<R:160/big-unsigned-integer, S:160/big-unsigned-integer>>; + mk_dss_sig(public_key:sign(SigData, HashAlg, Key)); sign(SigData, HashAlg, Key = #'ECPrivateKey'{}) -> DerEncodedSign = public_key:sign(SigData, HashAlg, Key), #'ECDSA-Sig-Value'{r=R, s=S} = public_key:der_decode('ECDSA-Sig-Value', DerEncodedSign), @@ -1266,7 +1282,13 @@ sign(SigData, HashAlg, Key = #'ECPrivateKey'{}) -> sign(SigData, HashAlg, Key) -> public_key:sign(SigData, HashAlg, Key). -verify(PlainText, HashAlg, Sig, {_, #'Dss-Parms'{}} = Key) -> + +mk_dss_sig(DerSignature) -> + #'Dss-Sig-Value'{r = R, s = S} = public_key:der_decode('Dss-Sig-Value', DerSignature), + <<R:160/big-unsigned-integer, S:160/big-unsigned-integer>>. + + +verify(PlainText, HashAlg, Sig, {_, #'Dss-Parms'{}} = Key, _) -> case Sig of <<R:160/big-unsigned-integer, S:160/big-unsigned-integer>> -> Signature = public_key:der_encode('Dss-Sig-Value', #'Dss-Sig-Value'{r = R, s = S}), @@ -1274,7 +1296,7 @@ verify(PlainText, HashAlg, Sig, {_, #'Dss-Parms'{}} = Key) -> _ -> false end; -verify(PlainText, HashAlg, Sig, {#'ECPoint'{},_} = Key) -> +verify(PlainText, HashAlg, Sig, {#'ECPoint'{},_} = Key, _) -> case Sig of <<?UINT32(Rlen),R:Rlen/big-signed-integer-unit:8, ?UINT32(Slen),S:Slen/big-signed-integer-unit:8>> -> @@ -1284,7 +1306,15 @@ verify(PlainText, HashAlg, Sig, {#'ECPoint'{},_} = Key) -> _ -> false end; -verify(PlainText, HashAlg, Sig, Key) -> + +verify(PlainText, HashAlg, Sig, #'RSAPublicKey'{}=Key, #ssh{role = server, + c_version = "SSH-2.0-OpenSSH_7."++_}) + when HashAlg == sha256; HashAlg == sha512 -> + %% Public key signing bug in in OpenSSH >= 7.2 + public_key:verify(PlainText, HashAlg, Sig, Key) + orelse public_key:verify(PlainText, sha, Sig, Key); + +verify(PlainText, HashAlg, Sig, Key, _) -> public_key:verify(PlainText, HashAlg, Sig, Key). @@ -1817,6 +1847,8 @@ kex_alg_dependent({Min, NBits, Max, Prime, Gen, E, F, K}) -> %%%---------------------------------------------------------------- +valid_key_sha_alg(#{engine:=_, key_id:=_}, _Alg) -> true; % Engine key + valid_key_sha_alg(#'RSAPublicKey'{}, 'rsa-sha2-512') -> true; valid_key_sha_alg(#'RSAPublicKey'{}, 'rsa-sha2-384') -> true; valid_key_sha_alg(#'RSAPublicKey'{}, 'rsa-sha2-256') -> true; @@ -1830,11 +1862,14 @@ valid_key_sha_alg(#'RSAPrivateKey'{}, 'ssh-rsa' ) -> true; valid_key_sha_alg({_, #'Dss-Parms'{}}, 'ssh-dss') -> true; valid_key_sha_alg(#'DSAPrivateKey'{}, 'ssh-dss') -> true; -valid_key_sha_alg({#'ECPoint'{},{namedCurve,OID}}, Alg) -> sha(OID) == sha(Alg); -valid_key_sha_alg(#'ECPrivateKey'{parameters = {namedCurve,OID}}, Alg) -> sha(OID) == sha(Alg); +valid_key_sha_alg({#'ECPoint'{},{namedCurve,OID}}, Alg) -> valid_key_sha_alg_ec(OID, Alg); +valid_key_sha_alg(#'ECPrivateKey'{parameters = {namedCurve,OID}}, Alg) -> valid_key_sha_alg_ec(OID, Alg); valid_key_sha_alg(_, _) -> false. - +valid_key_sha_alg_ec(OID, Alg) -> + Curve = public_key:oid2ssh_curvename(OID), + Alg == list_to_atom("ecdsa-sha2-" ++ binary_to_list(Curve)). + public_algo(#'RSAPublicKey'{}) -> 'ssh-rsa'; % FIXME: Not right with draft-curdle-rsa-sha2 public_algo({_, #'Dss-Parms'{}}) -> 'ssh-dss'; @@ -2000,12 +2035,6 @@ same(Algs) -> [{client2server,Algs}, {server2client,Algs}]. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% trim_tail(Str) -> - lists:reverse(trim_head(lists:reverse(Str))). - -trim_head([$\s|Cs]) -> trim_head(Cs); -trim_head([$\t|Cs]) -> trim_head(Cs); -trim_head([$\n|Cs]) -> trim_head(Cs); -trim_head([$\r|Cs]) -> trim_head(Cs); -trim_head(Cs) -> Cs. - - + lists:takewhile(fun(C) -> + C=/=$\r andalso C=/=$\n + end, Str). diff --git a/lib/ssh/test/Makefile b/lib/ssh/test/Makefile index 5ea048a352..21359a0386 100644 --- a/lib/ssh/test/Makefile +++ b/lib/ssh/test/Makefile @@ -37,7 +37,9 @@ MODULES= \ ssh_renegotiate_SUITE \ ssh_basic_SUITE \ ssh_bench_SUITE \ + ssh_compat_SUITE \ ssh_connection_SUITE \ + ssh_engine_SUITE \ ssh_protocol_SUITE \ ssh_property_test_SUITE \ ssh_sftp_SUITE \ @@ -49,6 +51,7 @@ MODULES= \ ssh_test_lib \ ssh_key_cb \ ssh_key_cb_options \ + ssh_key_cb_engine_keys \ ssh_trpt_test_lib \ ssh_echo_server \ ssh_bench_dev_null \ diff --git a/lib/ssh/test/property_test/ssh_eqc_client_info_timing.erl b/lib/ssh/test/property_test/ssh_eqc_client_info_timing.erl index c07140dc43..19e2754eba 100644 --- a/lib/ssh/test/property_test/ssh_eqc_client_info_timing.erl +++ b/lib/ssh/test/property_test/ssh_eqc_client_info_timing.erl @@ -57,9 +57,9 @@ %%% Properties: -prop_seq(_Config) -> +prop_seq(Config) -> {ok,Pid} = ssh_eqc_event_handler:add_report_handler(), - {_, _, Port} = init_daemon(), + {_, _, Port} = init_daemon(Config), numtests(1000, ?FORALL(Delay, choose(0,100),%% Micro seconds try @@ -86,7 +86,8 @@ any_relevant_error_report(Pid) -> end, Reports). %%%================================================================ -init_daemon() -> +init_daemon(Config) -> ok = begin ssh:stop(), ssh:start() end, - ssh_test_lib:daemon([]). + DataDir = proplists:get_value(data_dir, Config), + ssh_test_lib:daemon([{system_dir,DataDir}]). diff --git a/lib/ssh/test/ssh_algorithms_SUITE.erl b/lib/ssh/test/ssh_algorithms_SUITE.erl index 98964a2c8a..de6e448ebd 100644 --- a/lib/ssh/test/ssh_algorithms_SUITE.erl +++ b/lib/ssh/test/ssh_algorithms_SUITE.erl @@ -29,15 +29,13 @@ %% Note: This directive should only be used in test suites. -compile(export_all). --define(TIMEOUT, 35000). - %%-------------------------------------------------------------------- %% Common Test interface functions ----------------------------------- %%-------------------------------------------------------------------- suite() -> [{ct_hooks,[ts_install_cth]}, - {timetrap,{seconds,40}}]. + {timetrap,{seconds,round(1.5*?TIMEOUT/1000)}}]. all() -> %% [{group,kex},{group,cipher}... etc @@ -90,7 +88,7 @@ init_per_suite(Config) -> " -- Max num algorithms: ~p~n" ,[os:getenv("HOME"), init:get_argument(home), - os:cmd("ssh -V"), + ssh_test_lib:installed_ssh_version("TIMEOUT"), ssh:default_algorithms(), crypto:info_lib(), ssh_test_lib:default_algorithms(sshc), @@ -318,10 +316,10 @@ sshc_simple_exec_os_cmd(Config) -> ok; false -> ct:log("Bad result: ~p~nExpected: ~p~nMangled result: ~p", [RawResult,Expect,Lines]), - {fail, "Bad result"} + {fail, "Bad result (see log in testcase)"} end after ?TIMEOUT -> - ct:fail("Did not receive answer") + ct:fail("Did not receive answer (timeout)") end. %%-------------------------------------------------------------------- diff --git a/lib/ssh/test/ssh_basic_SUITE.erl b/lib/ssh/test/ssh_basic_SUITE.erl index db2ae241e5..202b0afe57 100644 --- a/lib/ssh/test/ssh_basic_SUITE.erl +++ b/lib/ssh/test/ssh_basic_SUITE.erl @@ -46,6 +46,7 @@ exec_key_differs2/1, exec_key_differs3/1, exec_key_differs_fail/1, + fail_daemon_start/1, idle_time_client/1, idle_time_server/1, inet6_option/1, @@ -105,6 +106,7 @@ all() -> {group, host_user_key_differs}, {group, key_cb}, {group, internal_error}, + {group, rsa_host_key_is_actualy_ecdsa}, daemon_already_started, double_close, daemon_opt_fd, @@ -121,6 +123,7 @@ groups() -> {ecdsa_sha2_nistp256_key, [], basic_tests()}, {ecdsa_sha2_nistp384_key, [], basic_tests()}, {ecdsa_sha2_nistp521_key, [], basic_tests()}, + {rsa_host_key_is_actualy_ecdsa, [], [fail_daemon_start]}, {host_user_key_differs, [], [exec_key_differs1, exec_key_differs2, exec_key_differs3, @@ -180,6 +183,31 @@ init_per_group(rsa_key, Config) -> false -> {skip, unsupported_pub_key} end; +init_per_group(rsa_host_key_is_actualy_ecdsa, Config) -> + case + lists:member('ssh-rsa', + ssh_transport:default_algorithms(public_key)) and + lists:member('ecdsa-sha2-nistp256', + ssh_transport:default_algorithms(public_key)) + of + true -> + DataDir = proplists:get_value(data_dir, Config), + PrivDir = proplists:get_value(priv_dir, Config), + ssh_test_lib:setup_ecdsa("256", DataDir, PrivDir), + %% The following sets up bad rsa keys: + begin + UserDir = PrivDir, + System = filename:join(UserDir, "system"), + file:copy(filename:join(DataDir, "id_rsa"), filename:join(UserDir, "id_rsa")), + file:rename(filename:join(System, "ssh_host_ecdsa_key"), filename:join(System, "ssh_host_rsa_key")), + file:rename(filename:join(System, "ssh_host_ecdsa_key.pub"), filename:join(System, "ssh_host_rsa_key.pub")), + ssh_test_lib:setup_rsa_known_host(DataDir, UserDir), + ssh_test_lib:setup_rsa_auth_keys(DataDir, UserDir) + end, + Config; + false -> + {skip, unsupported_pub_key} + end; init_per_group(ecdsa_sha2_nistp256_key, Config) -> case lists:member('ecdsa-sha2-nistp256', ssh_transport:default_algorithms(public_key)) of @@ -304,7 +332,8 @@ init_per_group(internal_error, Config) -> DataDir = proplists:get_value(data_dir, Config), PrivDir = proplists:get_value(priv_dir, Config), ssh_test_lib:setup_dsa(DataDir, PrivDir), - file:delete(filename:join(PrivDir, "system/ssh_host_dsa_key")), + %% In the test case the key will be deleted after the daemon start: + %% ... file:delete(filename:join(PrivDir, "system/ssh_host_dsa_key")), Config; init_per_group(dir_options, Config) -> PrivDir = proplists:get_value(priv_dir, Config), @@ -868,12 +897,17 @@ key_callback_options(Config) when is_list(Config) -> %%% Test that client does not hang if disconnects due to internal error internal_error(Config) when is_list(Config) -> process_flag(trap_exit, true), - SystemDir = filename:join(proplists:get_value(priv_dir, Config), system), + PrivDir = proplists:get_value(priv_dir, Config), UserDir = proplists:get_value(priv_dir, Config), + SystemDir = filename:join(PrivDir, system), {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, {user_dir, UserDir}, {failfun, fun ssh_test_lib:failfun/2}]), + + %% Now provoke an error in the following connect: + file:delete(filename:join(PrivDir, "system/ssh_host_dsa_key")), + {error, Error} = ssh:connect(Host, Port, [{silently_accept_hosts, true}, {user_dir, UserDir}, @@ -902,6 +936,17 @@ send(Config) when is_list(Config) -> %%-------------------------------------------------------------------- +%%% +fail_daemon_start(Config) when is_list(Config) -> + process_flag(trap_exit, true), + SystemDir = filename:join(proplists:get_value(priv_dir, Config), system), + UserDir = proplists:get_value(priv_dir, Config), + + {error,_} = ssh_test_lib:daemon([{system_dir, SystemDir}, + {user_dir, UserDir}, + {failfun, fun ssh_test_lib:failfun/2}]). + +%%-------------------------------------------------------------------- %%% Test ssh:connection_info([peername, sockname]) peername_sockname(Config) when is_list(Config) -> process_flag(trap_exit, true), @@ -1300,14 +1345,11 @@ shell_exit_status(Config) when is_list(Config) -> %%-------------------------------------------------------------------- %% Due to timing the error message may or may not be delivered to %% the "tcp-application" before the socket closed message is recived -check_error("Invalid state") -> - ok; -check_error("Connection closed") -> - ok; -check_error("Selection of key exchange algorithm failed"++_) -> - ok; -check_error(Error) -> - ct:fail(Error). +check_error("Invalid state") -> ok; +check_error("Connection closed") -> ok; +check_error("Selection of key exchange algorithm failed"++_) -> ok; +check_error("No host key available") -> ok; +check_error(Error) -> ct:fail(Error). basic_test(Config) -> ClientOpts = proplists:get_value(client_opts, Config), diff --git a/lib/ssh/test/ssh_compat_SUITE.erl b/lib/ssh/test/ssh_compat_SUITE.erl new file mode 100644 index 0000000000..82b83dd83d --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE.erl @@ -0,0 +1,1398 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2008-2017. 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(ssh_compat_SUITE). + +-include_lib("common_test/include/ct.hrl"). +-include_lib("ssh/src/ssh_transport.hrl"). % #ssh_msg_kexinit{} +-include_lib("kernel/include/inet.hrl"). % #hostent{} +-include_lib("kernel/include/file.hrl"). % #file_info{} +-include("ssh_test_lib.hrl"). + +%% Note: This directive should only be used in test suites. +-compile(export_all). + +-define(USER,"sshtester"). +-define(PASSWD, "foobar"). +-define(BAD_PASSWD, "NOT-"?PASSWD). +-define(DOCKER_PFX, "ssh_compat_suite-ssh"). + +%%-------------------------------------------------------------------- +%% Common Test interface functions ----------------------------------- +%%-------------------------------------------------------------------- + +suite() -> + [%%{ct_hooks,[ts_install_cth]}, + {timetrap,{seconds,40}}]. + +all() -> +%% [check_docker_present] ++ + [{group,G} || G <- ssh_image_versions()]. + +groups() -> + [{otp_client, [], [login_otp_is_client, + all_algorithms_sftp_exec_reneg_otp_is_client, + send_recv_big_with_renegotiate_otp_is_client + ]}, + {otp_server, [], [login_otp_is_server, + all_algorithms_sftp_exec_reneg_otp_is_server + ]} | + [{G, [], [{group,otp_client}, {group,otp_server}]} || G <- ssh_image_versions()] + ]. + + +ssh_image_versions() -> + try + %% Find all useful containers in such a way that undefined command, too low + %% priviliges, no containers and containers found give meaningful result: + L0 = ["REPOSITORY"++_|_] = string:tokens(os:cmd("docker images"), "\r\n"), + [["REPOSITORY","TAG"|_]|L1] = [string:tokens(E, " ") || E<-L0], + [list_to_atom(V) || [?DOCKER_PFX,V|_] <- L1] + of + Vs -> + lists:sort(Vs) + catch + error:{badmatch,_} -> + [] + end. + +%%-------------------------------------------------------------------- +init_per_suite(Config) -> + ?CHECK_CRYPTO( + case os:find_executable("docker") of + false -> + {skip, "No docker"}; + _ -> + ssh:start(), + ct:log("Crypto info: ~p",[crypto:info_lib()]), + Config + end). + +end_per_suite(Config) -> + %% Remove all containers that are not running: +%%% os:cmd("docker rm $(docker ps -aq -f status=exited)"), + %% Remove dangling images: +%%% os:cmd("docker rmi $(docker images -f dangling=true -q)"), + Config. + + +init_per_group(otp_server, Config) -> + case proplists:get_value(common_remote_client_algs, Config) of + undefined -> + SSHver = proplists:get_value(ssh_version, Config, ""), + {skip,"No "++SSHver++ " client found in docker"}; + _ -> + Config + end; + +init_per_group(otp_client, Config) -> + Config; + +init_per_group(G, Config0) -> + case lists:member(G, ssh_image_versions()) of + true -> + %% This group is for one of the images + Vssh = atom_to_list(G), + Cmnt = io_lib:format("+++ ~s +++",[Vssh]), + ct:comment("~s",[Cmnt]), + try start_docker(G) of + {ok,ID} -> + ct:log("==> ~p started",[G]), + %% Find the algorithms that both client and server supports: + {IP,Port} = ip_port([{id,ID}]), + ct:log("Try contact ~p:~p",[IP,Port]), + Config1 = [{id,ID}, + {ssh_version,Vssh} + | Config0], + try common_algs(Config1, IP, Port) of + {ok, ServerHello, RemoteServerCommon, ClientHello, RemoteClientCommon} -> + case chk_hellos([ServerHello,ClientHello], Cmnt) of + Cmnt -> + ok; + NewCmnt -> + ct:comment("~s",[NewCmnt]) + end, + AuthMethods = + %% This should be obtained by quering the peer, but that + %% is a bit hard. It is possible with ssh_protocol_SUITE + %% techniques, but it can wait. + case Vssh of + "dropbear" ++ _ -> + [password, publickey]; + _ -> + [password, 'keyboard-interactive', publickey] + end, + [{common_remote_server_algs,RemoteServerCommon}, + {common_remote_client_algs,RemoteClientCommon}, + {common_authmethods,AuthMethods} + |Config1]; + Other -> + ct:log("Error in init_per_group: ~p",[Other]), + stop_docker(ID), + {fail, "Can't contact docker sshd"} + catch + Class:Exc -> + ST = erlang:get_stacktrace(), + ct:log("common_algs: ~p:~p~n~p",[Class,Exc,ST]), + stop_docker(ID), + {fail, "Failed during setup"} + end + catch + cant_start_docker -> + {skip, "Can't start docker"}; + + C:E -> + ST = erlang:get_stacktrace(), + ct:log("No ~p~n~p:~p~n~p",[G,C,E,ST]), + {skip, "Can't start docker"} + end; + + false -> + Config0 + end. + +end_per_group(G, Config) -> + case lists:member(G, ssh_image_versions()) of + true -> + catch stop_docker(proplists:get_value(id,Config)); + false -> + ok + end. + +%%-------------------------------------------------------------------- +%% Test Cases -------------------------------------------------------- +%%-------------------------------------------------------------------- +check_docker_present(_Config) -> + ct:log("This testcase is just to show in Monitor that we have a test host with docker installed",[]), + {fail, "Test is OK: just showing docker is available"}. + +%%-------------------------------------------------------------------- +login_otp_is_client(Config) -> + {IP,Port} = ip_port(Config), + PublicKeyAlgs = [A || {public_key,A} <- proplists:get_value(common_remote_server_algs, Config)], + CommonAuths = + [{AuthMethod,Alg} || AuthMethod <- proplists:get_value(common_authmethods, Config), + Alg <- case AuthMethod of + publickey -> + PublicKeyAlgs; + _ -> + [' '] + end + ], + + chk_all_algos(?FUNCTION_NAME, CommonAuths, Config, + fun(AuthMethod,Alg) -> + {Opts,Dir} = + case AuthMethod of + publickey -> + {[], setup_remote_auth_keys_and_local_priv(Alg, Config)}; + _ -> + {[{password,?PASSWD}], new_dir(Config)} + end, + ssh:connect(IP, Port, [{auth_methods, atom_to_list(AuthMethod)}, + {user,?USER}, + {user_dir, Dir}, + {silently_accept_hosts,true}, + {user_interaction,false} + | Opts + ]) + end). + + +%%-------------------------------------------------------------------- +login_otp_is_server(Config) -> + PublicKeyAlgs = [A || {public_key,A} <- proplists:get_value(common_remote_client_algs, Config)], + CommonAuths = + [{AuthMethod,Alg} || AuthMethod <- proplists:get_value(common_authmethods, Config), + Alg <- case AuthMethod of + publickey -> + PublicKeyAlgs; + _ -> + [' '] + end + ], + SysDir = setup_local_hostdir(hd(PublicKeyAlgs), Config), + chk_all_algos(?FUNCTION_NAME, CommonAuths, Config, + fun(AuthMethod,Alg) -> + {Opts,UsrDir} = + case AuthMethod of + publickey -> + {[{user_passwords, [{?USER,?BAD_PASSWD}]}], + setup_remote_priv_and_local_auth_keys(Alg, Config) + }; + _ -> + {[{user_passwords, [{?USER,?PASSWD}]}], + new_dir(Config) + } + end, + {Server, Host, HostPort} = + ssh_test_lib:daemon(0, + [{auth_methods, atom_to_list(AuthMethod)}, + {system_dir, SysDir}, + {user_dir, UsrDir}, + {failfun, fun ssh_test_lib:failfun/2} + | Opts + ]), + R = exec_from_docker(Config, Host, HostPort, + "'lists:concat([\"Answer=\",1+3]).\r\n'", + [<<"Answer=4">>], + ""), + ssh:stop_daemon(Server), + R + end). + +%%-------------------------------------------------------------------- +all_algorithms_sftp_exec_reneg_otp_is_client(Config) -> + CommonAlgs = proplists:get_value(common_remote_server_algs, Config), + {IP,Port} = ip_port(Config), + chk_all_algos(?FUNCTION_NAME, CommonAlgs, Config, + fun(Tag, Alg) -> + ConnRes = + ssh:connect(IP, Port, + [{user,?USER}, + {password,?PASSWD}, + {auth_methods, "password"}, + {user_dir, new_dir(Config)}, + {preferred_algorithms, [{Tag,[Alg]}]}, + {silently_accept_hosts,true}, + {user_interaction,false} + ]) , + test_erl_client_reneg(ConnRes, % Seems that max 10 channels may be open in sshd + [{exec,1}, + {sftp,5}, + {no_subsyst,1}, + {setenv, 1}, + {sftp_async,1} + ]) + end). + +%%-------------------------------------------------------------------- +all_algorithms_sftp_exec_reneg_otp_is_server(Config) -> + CommonAlgs = proplists:get_value(common_remote_client_algs, Config), + UserDir = setup_remote_priv_and_local_auth_keys('ssh-rsa', Config), + chk_all_algos(?FUNCTION_NAME, CommonAlgs, Config, + fun(Tag,Alg) -> + HostKeyAlg = case Tag of + public_key -> Alg; + _ -> 'ssh-rsa' + end, + SftpRootDir = new_dir(Config), + %% ct:log("Rootdir = ~p",[SftpRootDir]), + {Server, Host, HostPort} = + ssh_test_lib:daemon(0, + [{preferred_algorithms, [{Tag,[Alg]}]}, + {system_dir, setup_local_hostdir(HostKeyAlg, Config)}, + {user_dir, UserDir}, + {user_passwords, [{?USER,?PASSWD}]}, + {failfun, fun ssh_test_lib:failfun/2}, + {subsystems, + [ssh_sftpd:subsystem_spec([{cwd,SftpRootDir}, + {root,SftpRootDir}]), + {"echo_10",{ssh_echo_server,[10,[{dbg,true}]]}} + ]} + ]), + R = do([fun() -> + exec_from_docker(Config, Host, HostPort, + "hi_there.\r\n", + [<<"hi_there">>], + "") + end, + fun() -> + sftp_tests_erl_server(Config, Host, HostPort, SftpRootDir, UserDir) + end + ]), + ssh:stop_daemon(Server), + R + end). + +%%-------------------------------------------------------------------- +send_recv_big_with_renegotiate_otp_is_client(Config) -> + %% Connect to the remote openssh server: + {IP,Port} = ip_port(Config), + {ok,C} = ssh:connect(IP, Port, [{user,?USER}, + {password,?PASSWD}, + {user_dir, setup_remote_auth_keys_and_local_priv('ssh-rsa', Config)}, + {silently_accept_hosts,true}, + {user_interaction,false} + ]), + + %% Open a channel and exec the Linux 'cat' command at the openssh side. + %% This 'cat' will read stdin and write to stdout until an eof is read from stdin. + {ok, Ch1} = ssh_connection:session_channel(C, infinity), + success = ssh_connection:exec(C, Ch1, "cat", infinity), + + %% Build big binary + HalfSizeBytes = 100*1000*1000, + Data = << <<X:32>> || X <- lists:seq(1, HalfSizeBytes div 4)>>, + + %% Send the data. Must spawn a process to avoid deadlock. The client will block + %% until all is sent through the send window. But the server will stop receiveing + %% when the servers send-window towards the client is full. + %% Since the client can't receive before the server has received all but 655k from the client + %% ssh_connection:send/4 is blocking... + spawn_link( + fun() -> + ct:comment("Sending ~p Mbytes with renegotiation in the middle",[2*byte_size(Data)/1000000]), + %% ct:log("sending first ~p bytes",[byte_size(Data)]), + ok = ssh_connection:send(C, Ch1, Data, 10000), + %% ct:log("Init renegotiation test",[]), + Kex1 = renegotiate_test(init, C), + %% ct:log("sending next ~p bytes",[byte_size(Data)]), + ok = ssh_connection:send(C, Ch1, Data, 10000), + %% ct:log("Finnish renegotiation test",[]), + renegotiate_test(Kex1, C), + %% ct:log("sending eof",[]), + ok = ssh_connection:send_eof(C, Ch1) + %%, ct:log("READY, sent ~p bytes",[2*byte_size(Data)]) + end), + + {eof,ReceivedData} = + loop_until(fun({eof,_}) -> true; + (_ ) -> false + end, + fun(Acc) -> + %%ct:log("Get more ~p",[ ExpectedSize-byte_size(Acc) ]), + receive + {ssh_cm, C, {eof,Ch}} when Ch==Ch1 -> + %% ct:log("eof received",[]), + {eof,Acc}; + + {ssh_cm, C, {data,Ch,0,B}} when Ch==Ch1, + is_binary(B) -> + %% ct:log("(1) Received ~p bytes (total ~p), missing ~p bytes", + %% [byte_size(B), + %% byte_size(B)+byte_size(Acc), + %% 2*byte_size(Data)-(byte_size(B)+byte_size(Acc))]), + ssh_connection:adjust_window(C, Ch1, byte_size(B)), + <<Acc/binary, B/binary>> + end + end, + <<>>), + + ExpectedData = <<Data/binary, Data/binary>>, + case ReceivedData of + ExpectedData -> + %% ct:log("Correct data returned",[]), + %% receive close messages + loop_until(fun(Left) -> %% ct:log("Expect: ~p",[Left]), + Left == [] + end, + fun([Next|Rest]) -> + receive + {ssh_cm,C,Next} -> Rest + end + end, + [%% Already received: {eof, Ch1}, + {exit_status,Ch1,0}, + {closed,Ch1}] + ), + ok; + _ when is_binary(ReceivedData) -> + ct:fail("~p bytes echoed but ~p expected", [byte_size(ReceivedData), 2*byte_size(Data)]) + end. + +%%-------------------------------------------------------------------- +%% Utilities --------------------------------------------------------- +%%-------------------------------------------------------------------- + +%%-------------------------------------------------------------------- +%% +%% A practical meta function +%% +loop_until(CondFun, DoFun, Acc) -> + case CondFun(Acc) of + true -> + Acc; + false -> + loop_until(CondFun, DoFun, DoFun(Acc)) + end. + +%%-------------------------------------------------------------------- +%% +%% Exec the Command in the docker. Add the arguments ExtraSshArg in the +%% ssh command. +%% +%% If Expects is returned, then return 'ok', else return {fail,Msg}. +%% +exec_from_docker(Config, HostIP, HostPort, Command, Expects, ExtraSshArg) when is_binary(hd(Expects)), + is_list(Config) -> + {DockerIP,DockerPort} = ip_port(Config), + {ok,C} = ssh:connect(DockerIP, DockerPort, + [{user,?USER}, + {password,?PASSWD}, + {user_dir, new_dir(Config)}, + {silently_accept_hosts,true}, + {user_interaction,false} + ]), + R = exec_from_docker(C, HostIP, HostPort, Command, Expects, ExtraSshArg, Config), + ssh:close(C), + R. + +exec_from_docker(C, DestIP, DestPort, Command, Expects, ExtraSshArg, Config) when is_binary(hd(Expects)) -> + ExecCommand = + lists:concat( + ["sshpass -p ",?PASSWD," " + | case proplists:get_value(ssh_version,Config) of + "dropbear" ++ _ -> + ["dbclient -y -y -p ",DestPort," ",ExtraSshArg," ",iptoa(DestIP)," "]; + + _ -> %% OpenSSH or compatible + ["/buildroot/ssh/bin/ssh -o 'CheckHostIP=no' -o 'StrictHostKeyChecking=no' ", + ExtraSshArg," -p ",DestPort," ",iptoa(DestIP)," "] + end]) ++ Command, + + case exec(C, ExecCommand) of + {ok,{ExitStatus,Result}} = R when ExitStatus == 0 -> + case binary:match(Result, Expects) of + nomatch -> + ct:log("Result of~n ~s~nis~n ~p",[ExecCommand,R]), + {fail, "Bad answer"}; + _ -> + ok + end; + {ok,_} = R -> + ct:log("Result of~n ~s~nis~n ~p",[ExecCommand,R]), + {fail, "Exit status =/= 0"}; + R -> + ct:log("Result of~n ~s~nis~n ~p",[ExecCommand,R]), + {fail, "Couldn't login to host"} + end. + + +exec(C, Cmd) -> + %% ct:log("~s",[Cmd]), + {ok,Ch} = ssh_connection:session_channel(C, 10000), + success = ssh_connection:exec(C, Ch, Cmd, 10000), + result_of_exec(C, Ch). + + +result_of_exec(C, Ch) -> + result_of_exec(C, Ch, undefined, <<>>). + +result_of_exec(C, Ch, ExitStatus, Acc) -> + receive + {ssh_cm,C,{closed,Ch}} -> + %%ct:log("CHAN ~p got *closed*",[Ch]), + {ok, {ExitStatus, Acc}}; + + {ssh_cm,C,{exit_status,Ch,ExStat}} when ExitStatus == undefined -> + %%ct:log("CHAN ~p got *exit status ~p*",[Ch,ExStat]), + result_of_exec(C, Ch, ExStat, Acc); + + {ssh_cm,C,{data,Ch,_,Data}=_X} when ExitStatus == undefined -> + %%ct:log("CHAN ~p got ~p",[Ch,_X]), + result_of_exec(C, Ch, ExitStatus, <<Acc/binary, Data/binary>>); + + _Other -> + %%ct:log("OTHER: ~p",[_Other]), + result_of_exec(C, Ch, ExitStatus, Acc) + + after 5000 -> + ct:log("NO MORE, received so far:~n~s",[Acc]), + {error, timeout} + end. + + +%%-------------------------------------------------------------------- +%% +%% Loop through all {Tag,Alg} pairs in CommonAlgs, call DoTestFun(Tag,Alg) which +%% returns one of {ok,C}, ok, or Other. +%% +%% The chk_all_algos returns 'ok' or {fail,FaledAlgosList} +%% + +chk_all_algos(FunctionName, CommonAlgs, Config, DoTestFun) when is_function(DoTestFun,2) -> + ct:comment("~p algorithms",[length(CommonAlgs)]), + %% Check each algorithm + Failed = + lists:foldl( + fun({Tag,Alg}, FailedAlgos) -> + %% ct:log("Try ~p",[Alg]), + case DoTestFun(Tag,Alg) of + {ok,C} -> + ssh:close(C), + FailedAlgos; + ok -> + FailedAlgos; + Other -> + ct:log("FAILED! ~p ~p: ~p",[Tag,Alg,Other]), + [{Alg,Other}|FailedAlgos] + end + end, [], CommonAlgs), + ct:pal("~s", [format_result_table_use_all_algos(FunctionName, Config, CommonAlgs, Failed)]), + case Failed of + [] -> + ok; + _ -> + {fail, Failed} + end. + + + +%%%---------------------------------------------------------------- +%%% +%%% Call all Funs as Fun() which returns 'ok', {ok,C} or Other. +%%% do/1 returns 'ok' or the first encountered value that is not +%%% successful. +%%% + +do(Funs) -> + do(Funs, 1). + +do([Fun|Funs], N) -> + case Fun() of + ok -> + %% ct:log("Fun ~p ok",[N]), + do(Funs, N-1); + {ok,C} -> + %% ct:log("Fun ~p {ok,C}",[N]), + ssh:close(C), + do(Funs, N-1); + Other -> + ct:log("Fun ~p FAILED:~n~p",[N, Other]), + Other + end; + +do([], _) -> + %% ct:log("All Funs ok",[]), + ok. + +%%-------------------------------------------------------------------- +%% +%% Functions to set up local and remote host's and user's keys and directories +%% + +setup_local_hostdir(KeyAlg, Config) -> + setup_local_hostdir(KeyAlg, new_dir(Config), Config). +setup_local_hostdir(KeyAlg, HostDir, Config) -> + {ok, {Priv,Publ}} = host_priv_pub_keys(Config, KeyAlg), + %% Local private and public key + DstFile = filename:join(HostDir, dst_filename(host,KeyAlg)), + ok = file:write_file(DstFile, Priv), + ok = file:write_file(DstFile++".pub", Publ), + HostDir. + + +setup_remote_auth_keys_and_local_priv(KeyAlg, Config) -> + {IP,Port} = ip_port(Config), + setup_remote_auth_keys_and_local_priv(KeyAlg, IP, Port, new_dir(Config), Config). + +setup_remote_auth_keys_and_local_priv(KeyAlg, UserDir, Config) -> + {IP,Port} = ip_port(Config), + setup_remote_auth_keys_and_local_priv(KeyAlg, IP, Port, UserDir, Config). + +setup_remote_auth_keys_and_local_priv(KeyAlg, IP, Port, Config) -> + setup_remote_auth_keys_and_local_priv(KeyAlg, IP, Port, new_dir(Config), Config). + +setup_remote_auth_keys_and_local_priv(KeyAlg, IP, Port, UserDir, Config) -> + {ok, {Priv,Publ}} = user_priv_pub_keys(Config, KeyAlg), + %% Local private and public keys + DstFile = filename:join(UserDir, dst_filename(user,KeyAlg)), + ok = file:write_file(DstFile, Priv), + ok = file:write_file(DstFile++".pub", Publ), + %% Remote auth_methods with public key + {ok,Ch,Cc} = ssh_sftp:start_channel(IP, Port, [{user, ?USER }, + {password, ?PASSWD }, + {auth_methods, "password"}, + {silently_accept_hosts,true}, + {user_interaction,false} + ]), + _ = ssh_sftp:make_dir(Ch, ".ssh"), + ok = ssh_sftp:write_file(Ch, ".ssh/authorized_keys", Publ), + ok = ssh_sftp:write_file_info(Ch, ".ssh/authorized_keys", #file_info{mode=8#700}), + ok = ssh_sftp:write_file_info(Ch, ".ssh", #file_info{mode=8#700}), + ok = ssh_sftp:stop_channel(Ch), + ok = ssh:close(Cc), + UserDir. + + +setup_remote_priv_and_local_auth_keys(KeyAlg, Config) -> + {IP,Port} = ip_port(Config), + setup_remote_priv_and_local_auth_keys(KeyAlg, IP, Port, new_dir(Config), Config). + +setup_remote_priv_and_local_auth_keys(KeyAlg, UserDir, Config) -> + {IP,Port} = ip_port(Config), + setup_remote_priv_and_local_auth_keys(KeyAlg, IP, Port, UserDir, Config). + +setup_remote_priv_and_local_auth_keys(KeyAlg, IP, Port, Config) -> + setup_remote_priv_and_local_auth_keys(KeyAlg, IP, Port, new_dir(Config), Config). + +setup_remote_priv_and_local_auth_keys(KeyAlg, IP, Port, UserDir, Config) -> + {ok, {Priv,Publ}} = user_priv_pub_keys(Config, KeyAlg), + %% Local auth_methods with public key + AuthKeyFile = filename:join(UserDir, "authorized_keys"), + ok = file:write_file(AuthKeyFile, Publ), + %% Remote private and public key + {ok,Ch,Cc} = ssh_sftp:start_channel(IP, Port, [{user, ?USER }, + {password, ?PASSWD }, + {auth_methods, "password"}, + {silently_accept_hosts,true}, + {user_interaction,false} + ]), + _ = ssh_sftp:make_dir(Ch, ".ssh"), + DstFile = filename:join(".ssh", dst_filename(user,KeyAlg)), + ok = ssh_sftp:write_file(Ch, DstFile, Priv), + ok = ssh_sftp:write_file_info(Ch, DstFile, #file_info{mode=8#700}), + ok = ssh_sftp:write_file(Ch, DstFile++".pub", Publ), + ok = ssh_sftp:write_file_info(Ch, ".ssh", #file_info{mode=8#700}), + ok = ssh_sftp:stop_channel(Ch), + ok = ssh:close(Cc), + UserDir. + +user_priv_pub_keys(Config, KeyAlg) -> priv_pub_keys("users_keys", user, Config, KeyAlg). +host_priv_pub_keys(Config, KeyAlg) -> priv_pub_keys("host_keys", host, Config, KeyAlg). + +priv_pub_keys(KeySubDir, Type, Config, KeyAlg) -> + KeyDir = filename:join(proplists:get_value(data_dir,Config), KeySubDir), + {ok,Priv} = file:read_file(filename:join(KeyDir,src_filename(Type,KeyAlg))), + {ok,Publ} = file:read_file(filename:join(KeyDir,src_filename(Type,KeyAlg)++".pub")), + {ok, {Priv,Publ}}. + + +%%%---------------- The default filenames +src_filename(user, 'ssh-rsa' ) -> "id_rsa"; +src_filename(user, 'rsa-sha2-256' ) -> "id_rsa"; +src_filename(user, 'rsa-sha2-512' ) -> "id_rsa"; +src_filename(user, 'ssh-dss' ) -> "id_dsa"; +src_filename(user, 'ecdsa-sha2-nistp256') -> "id_ecdsa256"; +src_filename(user, 'ecdsa-sha2-nistp384') -> "id_ecdsa384"; +src_filename(user, 'ecdsa-sha2-nistp521') -> "id_ecdsa521"; +src_filename(host, 'ssh-rsa' ) -> "ssh_host_rsa_key"; +src_filename(host, 'rsa-sha2-256' ) -> "ssh_host_rsa_key"; +src_filename(host, 'rsa-sha2-512' ) -> "ssh_host_rsa_key"; +src_filename(host, 'ssh-dss' ) -> "ssh_host_dsa_key"; +src_filename(host, 'ecdsa-sha2-nistp256') -> "ssh_host_ecdsa_key256"; +src_filename(host, 'ecdsa-sha2-nistp384') -> "ssh_host_ecdsa_key384"; +src_filename(host, 'ecdsa-sha2-nistp521') -> "ssh_host_ecdsa_key521". + +dst_filename(user, 'ssh-rsa' ) -> "id_rsa"; +dst_filename(user, 'rsa-sha2-256' ) -> "id_rsa"; +dst_filename(user, 'rsa-sha2-512' ) -> "id_rsa"; +dst_filename(user, 'ssh-dss' ) -> "id_dsa"; +dst_filename(user, 'ecdsa-sha2-nistp256') -> "id_ecdsa"; +dst_filename(user, 'ecdsa-sha2-nistp384') -> "id_ecdsa"; +dst_filename(user, 'ecdsa-sha2-nistp521') -> "id_ecdsa"; +dst_filename(host, 'ssh-rsa' ) -> "ssh_host_rsa_key"; +dst_filename(host, 'rsa-sha2-256' ) -> "ssh_host_rsa_key"; +dst_filename(host, 'rsa-sha2-512' ) -> "ssh_host_rsa_key"; +dst_filename(host, 'ssh-dss' ) -> "ssh_host_dsa_key"; +dst_filename(host, 'ecdsa-sha2-nistp256') -> "ssh_host_ecdsa_key"; +dst_filename(host, 'ecdsa-sha2-nistp384') -> "ssh_host_ecdsa_key"; +dst_filename(host, 'ecdsa-sha2-nistp521') -> "ssh_host_ecdsa_key". + + +%%-------------------------------------------------------------------- +%% +%% Format the result table for chk_all_algos/4 +%% +format_result_table_use_all_algos(FunctionName, Config, CommonAlgs, Failed) -> + %% Write a nice table with the result + AlgHead = 'Algorithm', + AlgWidth = lists:max([length(atom_to_list(A)) || {_,A} <- CommonAlgs]), + {ResultTable,_} = + lists:mapfoldl( + fun({T,A}, Tprev) -> + Tag = case T of + Tprev -> ""; + _ -> io_lib:format('~s~n',[T]) + end, + {io_lib:format('~s ~*s ~s~n', + [Tag, -AlgWidth, A, + case proplists:get_value(A,Failed) of + undefined -> "(ok)"; + Err -> io_lib:format("<<<< FAIL <<<< ~p",[Err]) + end]), + T} + end, undefined, CommonAlgs), + + Vssh = proplists:get_value(ssh_version,Config,""), + io_lib:format("~nResults of ~p, Peer version: ~s~n~n" + "Tag ~*s Result~n" + "=====~*..=s=======~n~s" + ,[FunctionName, Vssh, + -AlgWidth, AlgHead, + AlgWidth, "", ResultTable]). + +%%-------------------------------------------------------------------- +%% +%% Docker handling: start_docker/1 and stop_docker/1 +%% +start_docker(Ver) -> + Cmnd = lists:concat(["docker run -itd --rm -p 1234 ",?DOCKER_PFX,":",Ver]), + Id0 = os:cmd(Cmnd), + ct:log("Ver = ~p, Cmnd ~p~n-> ~p",[Ver,Cmnd,Id0]), + case is_docker_sha(Id0) of + true -> + Id = hd(string:tokens(Id0, "\n")), + IP = ip(Id), + Port = 1234, + {ok, {Ver,{IP,Port},Id}}; + false -> + throw(cant_start_docker) + end. + + +stop_docker({_Ver,_,Id}) -> + Cmnd = lists:concat(["docker kill ",Id]), + os:cmd(Cmnd). + +is_docker_sha(L) -> + lists:all(fun(C) when $a =< C,C =< $z -> true; + (C) when $0 =< C,C =< $9 -> true; + ($\n) -> true; + (_) -> false + end, L). + +%%-------------------------------------------------------------------- +%% +%% Misc docker info functions + +ip_port(Config) -> + {_Ver,{IP,Port},_} = proplists:get_value(id,Config), + {IP,Port}. + +port_mapped_to(Id) -> + Cmnd = lists:concat(["docker ps --format \"{{.Ports}}\" --filter id=",Id]), + [_, PortStr | _] = string:tokens(os:cmd(Cmnd), ":->/"), + list_to_integer(PortStr). + +ip(Id) -> + Cmnd = lists:concat(["docker inspect --format='{{range .NetworkSettings.Networks}}{{.IPAddress}}{{end}}' ", + Id]), + IPstr0 = os:cmd(Cmnd), + ct:log("Cmnd ~p~n-> ~p",[Cmnd,IPstr0]), + IPstr = hd(string:tokens(IPstr0, "\n")), + {ok,IP} = inet:parse_address(IPstr), + IP. + +%%-------------------------------------------------------------------- +%% +%% Normalize the host returned from ssh_test_lib + +iptoa({0,0,0,0}) -> inet_parse:ntoa(host_ip()); +iptoa(IP) -> inet_parse:ntoa(IP). + +host_ip() -> + {ok,Name} = inet:gethostname(), + {ok,#hostent{h_addr_list = [IP|_]}} = inet_res:gethostbyname(Name), + IP. + +%%-------------------------------------------------------------------- +%% +%% Create a new fresh directory or clear an existing one +%% + +new_dir(Config) -> + PrivDir = proplists:get_value(priv_dir, Config), + SubDirName = integer_to_list(erlang:system_time()), + Dir = filename:join(PrivDir, SubDirName), + case file:read_file_info(Dir) of + {error,enoent} -> + ok = file:make_dir(Dir), + Dir; + _ -> + timer:sleep(25), + new_dir(Config) + end. + +clear_dir(Dir) -> + delete_all_contents(Dir), + {ok,[]} = file:list_dir(Dir), + Dir. + +delete_all_contents(Dir) -> + {ok,Fs} = file:list_dir(Dir), + lists:map(fun(F0) -> + F = filename:join(Dir, F0), + case filelib:is_file(F) of + true -> + file:delete(F); + false -> + case filelib:is_dir(F) of + true -> + delete_all_contents(F), + file:del_dir(F); + false -> + ct:log("Neither file nor dir: ~p",[F]) + end + end + end, Fs). + +%%-------------------------------------------------------------------- +%% +%% Find the intersection of algoritms for otp ssh and the docker ssh. +%% Returns {ok, ServerHello, Server, ClientHello, Client} where Server are the algorithms common +%% with the docker server and analogous for Client. +%% +%% Client may be undefined if no usable client is found. +%% +%% Both Server and Client are lists of {Tag,AlgName}. +%% + +common_algs(Config, IP, Port) -> + case remote_server_algs(IP, Port) of + {ok, {ServerHello, RemoteServerKexInit}} -> + RemoteServerAlgs = kexint_msg2default_algorithms(RemoteServerKexInit), + Server = find_common_algs(RemoteServerAlgs, + use_algorithms(ServerHello)), + ct:log("Remote server:~n~p~n~p",[ServerHello, RemoteServerAlgs]), + case remote_client_algs(Config) of + {ok,{ClientHello,RemoteClientKexInit}} -> + RemoteClientAlgs = kexint_msg2default_algorithms(RemoteClientKexInit), + Client = find_common_algs(RemoteClientAlgs, + use_algorithms(ClientHello)), + ct:log("Remote client:~n~p~n~p",[ClientHello, RemoteClientAlgs]), + {ok, ServerHello, Server, ClientHello, Client}; + {error,_} =TO -> + ct:log("Remote client algs can't be found: ~p",[TO]), + {ok, ServerHello, Server, undefined, undefined}; + Other -> + Other + end; + Other -> + Other + end. + + +chk_hellos(Hs, Str) -> + lists:foldl( + fun(H, Acc) -> + try binary:split(H, <<"-">>, [global]) + of + %% [<<"SSH">>,<<"2.0">>|_] -> + %% Acc; + [<<"SSH">>,OldVer = <<"1.",_/binary>>|_] -> + io_lib:format("~s, Old SSH ver ~s",[Acc,OldVer]); + _ -> + Acc + catch + _:_ -> + Acc + end + end, Str, Hs). + + +find_common_algs(Remote, Local) -> + [{T,V} || {T,Vs} <- ssh_test_lib:extract_algos( + ssh_test_lib:intersection(Remote, + Local)), + V <- Vs]. + + +use_algorithms(RemoteHelloBin) -> + MyAlgos = ssh:chk_algos_opts( + [{modify_algorithms, + [{append, + [{kex,['diffie-hellman-group1-sha1']} + ]} + ]} + ]), + ssh_transport:adjust_algs_for_peer_version(binary_to_list(RemoteHelloBin)++"\r\n", + MyAlgos). + +kexint_msg2default_algorithms(#ssh_msg_kexinit{kex_algorithms = Kex, + server_host_key_algorithms = PubKey, + encryption_algorithms_client_to_server = CipherC2S, + encryption_algorithms_server_to_client = CipherS2C, + mac_algorithms_client_to_server = MacC2S, + mac_algorithms_server_to_client = MacS2C, + compression_algorithms_client_to_server = CompC2S, + compression_algorithms_server_to_client = CompS2C + }) -> + [{kex, ssh_test_lib:to_atoms(Kex)}, + {public_key, ssh_test_lib:to_atoms(PubKey)}, + {cipher, [{client2server,ssh_test_lib:to_atoms(CipherC2S)}, + {server2client,ssh_test_lib:to_atoms(CipherS2C)}]}, + {mac, [{client2server,ssh_test_lib:to_atoms(MacC2S)}, + {server2client,ssh_test_lib:to_atoms(MacS2C)}]}, + {compression, [{client2server,ssh_test_lib:to_atoms(CompC2S)}, + {server2client,ssh_test_lib:to_atoms(CompS2C)}]}]. + + +%%-------------------------------------------------------------------- +%% +%% Find the algorithms supported by the remote server +%% +%% Connect with tcp to the server, send a hello and read the returned +%% server hello and kexinit message. +%% +remote_server_algs(IP, Port) -> + case try_gen_tcp_connect(IP, Port, 5) of + {ok,S} -> + ok = gen_tcp:send(S, "SSH-2.0-CheckAlgs\r\n"), + receive_hello(S); + {error,Error} -> + {error,Error} + end. + +try_gen_tcp_connect(IP, Port, N) when N>0 -> + case gen_tcp:connect(IP, Port, [binary]) of + {ok,S} -> + {ok,S}; + {error,_Error} when N>1 -> + receive after 1000 -> ok end, + try_gen_tcp_connect(IP, Port, N-1); + {error,Error} -> + {error,Error} + end; +try_gen_tcp_connect(_, _, _) -> + {error, "No contact"}. + + +%%-------------------------------------------------------------------- +%% +%% Find the algorithms supported by the remote client +%% +%% Set up a fake ssh server and make the remote client connect to it. Use +%% hello message and the kexinit message. +%% +remote_client_algs(Config) -> + Parent = self(), + Ref = make_ref(), + spawn( + fun() -> + {ok,Sl} = gen_tcp:listen(0, [binary]), + {ok,{IP,Port}} = inet:sockname(Sl), + Parent ! {addr,Ref,IP,Port}, + {ok,S} = gen_tcp:accept(Sl), + ok = gen_tcp:send(S, "SSH-2.0-CheckAlgs\r\n"), + Parent ! {Ref,receive_hello(S)} + end), + receive + {addr,Ref,IP,Port} -> + spawn(fun() -> + exec_from_docker(Config, IP, Port, + "howdy.\r\n", + [<<"howdy">>], + "") + end), + receive + {Ref, Result} -> + Result + after 5000 -> + {error, {timeout,2}} + end + after 5000 -> + {error, {timeout,1}} + end. + + +%%% Receive a few packets from the remote server or client and find what is supported: + +receive_hello(S) -> + try + receive_hello(S, <<>>) + of + Result -> + Result + catch + Class:Error -> + ST = erlang:get_stacktrace(), + {error, {Class,Error,ST}} + end. + + +receive_hello(S, Ack) -> + %% The Ack is to collect bytes until the full message is received + receive + {tcp, S, Bin0} when is_binary(Bin0) -> + case binary:split(<<Ack/binary, Bin0/binary>>, [<<"\r\n">>,<<"\r">>,<<"\n">>]) of + [Hello = <<"SSH-2.0-",_/binary>>, NextPacket] -> + %% ct:log("Got 2.0 hello (~p), ~p bytes to next msg",[Hello,size(NextPacket)]), + {ok, {Hello, receive_kexinit(S, NextPacket)}}; + + [Hello = <<"SSH-1.99-",_/binary>>, NextPacket] -> + %% ct:log("Got 1.99 hello (~p), ~p bytes to next msg",[Hello,size(NextPacket)]), + {ok, {Hello, receive_kexinit(S, NextPacket)}}; + + [Bin] when size(Bin) < 256 -> + %% ct:log("Got part of hello (~p chars):~n~s~n~s",[size(Bin),Bin, + %% [io_lib:format('~2.16.0b ',[C]) + %% || C <- binary_to_list(Bin0) + %% ] + %% ]), + receive_hello(S, Bin0); + + _ -> + ct:log("Bad hello string (line ~p, ~p chars):~n~s~n~s",[?LINE,size(Bin0),Bin0, + [io_lib:format('~2.16.0b ',[C]) + || C <- binary_to_list(Bin0) + ] + ]), + ct:fail("Bad hello string received") + end; + Other -> + ct:log("Bad hello string (line ~p):~n~p",[?LINE,Other]), + ct:fail("Bad hello string received") + + after 10000 -> + ct:log("Timeout waiting for hello!~n~s",[Ack]), + throw(timeout) + end. + + +receive_kexinit(_S, <<PacketLen:32, PaddingLen:8, PayloadAndPadding/binary>>) + when PacketLen < 5000, % heuristic max len to stop huge attempts if packet decodeing get out of sync + size(PayloadAndPadding) >= (PacketLen-1) % Need more bytes? + -> + ct:log("Has all ~p packet bytes",[PacketLen]), + PayloadLen = PacketLen - PaddingLen - 1, + <<Payload:PayloadLen/binary, _Padding:PaddingLen/binary>> = PayloadAndPadding, + ssh_message:decode(Payload); + +receive_kexinit(S, Ack) -> + ct:log("Has ~p bytes, need more",[size(Ack)]), + receive + {tcp, S, Bin0} when is_binary(Bin0) -> + receive_kexinit(S, <<Ack/binary, Bin0/binary>>); + Other -> + ct:log("Bad hello string (line ~p):~n~p",[?LINE,Other]), + ct:fail("Bad hello string received") + + after 10000 -> + ct:log("Timeout waiting for kexinit!~n~s",[Ack]), + throw(timeout) + end. + +%%%---------------------------------------------------------------- +%%% Test of sftp from the OpenSSH client side +%%% + +sftp_tests_erl_server(Config, ServerIP, ServerPort, ServerRootDir, UserDir) -> + try + Cmnds = prepare_local_directory(ServerRootDir), + call_sftp_in_docker(Config, ServerIP, ServerPort, Cmnds, UserDir), + check_local_directory(ServerRootDir) + catch + Class:Error -> + ST = erlang:get_stacktrace(), + {error, {Class,Error,ST}} + end. + + +prepare_local_directory(ServerRootDir) -> + file:write_file(filename:join(ServerRootDir,"tst1"), + <<"Some test text">> + ), + ["get tst1", + "put tst1 tst2", + "put tst1 tst3", + "rename tst1 ex_tst1", + "rm tst3", + "mkdir mydir", + "cd mydir", + "put tst1 file_1", + "put tst1 unreadable_file", + "chmod 222 unreadable_file", + "exit"]. + +check_local_directory(ServerRootDir) -> + case lists:sort(ok(file:list_dir(ServerRootDir)) -- [".",".."]) of + ["ex_tst1","mydir","tst2"] -> + {ok,Expect} = file:read_file(filename:join(ServerRootDir,"ex_tst1")), + case file:read_file(filename:join(ServerRootDir,"tst2")) of + {ok,Expect} -> + case lists:sort(ok(file:list_dir(filename:join(ServerRootDir,"mydir"))) -- [".",".."]) of + ["file_1","unreadable_file"] -> + case file:read_file(filename:join([ServerRootDir,"mydir","file_1"])) of + {ok,Expect} -> + case file:read_file(filename:join([ServerRootDir,"mydir","unreadable_file"])) of + {error,_} -> + ok; + {ok,_} -> + {error, {could_read_unreadable,"mydir/unreadable_file"}} + end; + {ok,Other} -> + ct:log("file_1:~n~s~nExpected:~n~s",[Other,Expect]), + {error, {bad_contents_in_file,"mydir/file_1"}} + end; + Other -> + ct:log("Directory ~s~n~p",[filename:join(ServerRootDir,"mydir"),Other]), + {error,{bad_dir_contents,"mydir"}} + end; + {ok,Other} -> + ct:log("tst2:~n~s~nExpected:~n~s",[Other,Expect]), + {error, {bad_contents_in_file,"tst2"}} + end; + ["tst1"] -> + {error,{missing_file,"tst2"}}; + Other -> + ct:log("Directory ~s~n~p",[ServerRootDir,Other]), + {error,{bad_dir_contents,"/"}} + end. + +call_sftp_in_docker(Config, ServerIP, ServerPort, Cmnds, UserDir) -> + {DockerIP,DockerPort} = ip_port(Config), + {ok,C} = ssh:connect(DockerIP, DockerPort, + [{user,?USER}, + {password,?PASSWD}, + {user_dir, UserDir}, + {silently_accept_hosts,true}, + {user_interaction,false} + ]), + + %% Make commands for "expect" in the docker: + PreExpectCmnds = ["spawn /buildroot/ssh/bin/sftp -oPort="++integer_to_list(ServerPort)++ + " -oCheckHostIP=no -oStrictHostKeyChecking=no " ++ + iptoa(ServerIP)++"\n" + ], + PostExpectCmnds= [], + ExpectCmnds = + PreExpectCmnds ++ + ["expect \"sftp>\" {send \""++Cmnd++"\n\"}\n" || Cmnd <- Cmnds] ++ + PostExpectCmnds, + + %% Make an commands file in the docker + {ok,Ch} = ssh_sftp:start_channel(C, [{timeout,10000}]), + ok = ssh_sftp:write_file(Ch, "commands", erlang:iolist_to_binary(ExpectCmnds)), + ok = ssh_sftp:stop_channel(Ch), + + %% Call expect in the docker + {ok, Ch1} = ssh_connection:session_channel(C, infinity), + Kex1 = renegotiate_test(init, C), + success = ssh_connection:exec(C, Ch1, "expect commands", infinity), + + renegotiate_test(Kex1, C), + recv_log_msgs(C, Ch1), + + %% Done. + ssh:close(C). + +recv_log_msgs(C, Ch) -> + receive + {ssh_cm,C,{closed,Ch}} -> + %% ct:log("Channel closed ~p",[{closed,1}]), + ok; + {ssh_cm,C,{data,Ch,1,Msg}} -> + ct:log("*** ERROR from docker:~n~s",[Msg]), + recv_log_msgs(C, Ch); + {ssh_cm,C,_Msg} -> + %% ct:log("Got ~p",[_Msg]), + recv_log_msgs(C, Ch) + end. + +%%%---------------------------------------------------------------- +%%%---------------------------------------------------------------- +%%% +%%% Tests from the Erlang client side +%%% +%%%---------------------------------------------------------------- +%%%---------------------------------------------------------------- +test_erl_client_reneg({ok,C}, Spec) -> + %% Start the test processes on the connection C: + Parent = self(), + Pids = [spawn( + fun() -> + Parent ! {self(), TestType, Id, one_test_erl_client(TestType,Id,C)} + end + ) + || {TestType,N} <- Spec, + Id <- lists:seq(1,N)], + + Kex1 = renegotiate_test(init, C), + + %% Collect the results: + case lists:filter( + fun(R) -> R=/=ok end, + [receive + {Pid,_TestType,_Id,ok} -> + %% ct:log("Test ~p:~p passed!", [_TestType,_Id]), + ok; + {Pid,TestType,Id,OtherResult} -> + ct:log("~p:~p ~p ~p~n~p",[?MODULE,?LINE,TestType,Id,OtherResult]), + {error,TestType,Id} + end || Pid <- Pids]) + of + [] -> + renegotiate_test(Kex1, C), + {ok,C}; + Other -> + renegotiate_test(Kex1, C), + Other + end; + +test_erl_client_reneg(Error, _) -> + Error. + + +one_test_erl_client(exec, Id, C) -> + {ok, Ch} = ssh_connection:session_channel(C, infinity), + success = ssh_connection:exec(C, Ch, "echo Hi there", 5000), + case loop_until(fun({eof,_}) -> true; + (_ ) -> false + end, + fun(Acc) -> + receive + {ssh_cm, C, {eof,Ch}} -> + {eof,Acc}; + {ssh_cm, C, {data,Ch,0,B}} when is_binary(B) -> + <<Acc/binary, B/binary>> + end + end, + <<>>) of + {eof,<<"Hi there\n">>} -> + ok; + Other -> + ct:pal("exec Got other ~p", [Other]), + {error, {exec,Id,bad_msg,Other,undefined}} + end; + +one_test_erl_client(no_subsyst, Id, C) -> + {ok, Ch} = ssh_connection:session_channel(C, infinity), + case ssh_connection:subsystem(C, Ch, "foo", infinity) of + failure -> + ok; + Other -> + ct:pal("no_subsyst Got other ~p", [Other]), + {error, {no_subsyst,Id,bad_ret,Other,undefined}} + end; + +one_test_erl_client(setenv, Id, C) -> + {ok, Ch} = ssh_connection:session_channel(C, infinity), + Var = "ENV_TEST", + Value = lists:concat(["env_test_",Id,"_",erlang:system_time()]), + Env = case ssh_connection:setenv(C, Ch, Var, Value, infinity) of + success -> binary_to_list(Value++"\n"); + failure -> <<"\n">> + end, + success = ssh_connection:exec(C, Ch, "echo $"++Var, 5000), + case loop_until(fun({eof,_}) -> true; + (_ ) -> false + end, + fun(Acc) -> + receive + {ssh_cm, C, {eof,Ch}} -> + {eof,Acc}; + {ssh_cm, C, {data,Ch,0,B}} when is_binary(B) -> + <<Acc/binary, B/binary>> + end + end, + <<>>) of + {eof,Env} -> + ok; + Other -> + ct:pal("setenv Got other ~p", [Other]), + {error, {setenv,Id,bad_msg,Other,undefined}} + end; + +one_test_erl_client(SFTP, Id, C) when SFTP==sftp ; SFTP==sftp_async -> + try + {ok,Ch} = ssh_sftp:start_channel(C, [{timeout,10000}]), + %% A new fresh name of a new file tree: + RootDir = lists:concat(["r_",Id,"_",erlang:system_time()]), + %% Check that it does not exist: + false = lists:member(RootDir, ok(ssh_sftp:list_dir(Ch, "."))), + %% Create it: + ok = ssh_sftp:make_dir(Ch, RootDir), + {ok, #file_info{type=directory, access=read_write}} = ssh_sftp:read_file_info(Ch, RootDir), + R = do_sftp_tests_erl_client(SFTP, C, Ch, Id, RootDir), + catch ssh_sftp:stop_channel(Ch), + R + catch + Class:Error -> + ST = erlang:get_stacktrace(), + {error, {SFTP,Id,Class,Error,ST}} + end. + + + +do_sftp_tests_erl_client(sftp_async, _C, Ch, _Id, RootDir) -> + FileName1 = "boring_name", + F1 = filename:join(RootDir, FileName1), + %% Open a new handle and start writing: + {ok,Handle1} = ssh_sftp:open(Ch, F1, [write,binary]), + {async,Aref1} = ssh_sftp:awrite(Ch, Handle1, <<0:250000/unsigned-unit:8>>), + wait_for_async_result(Aref1); + +do_sftp_tests_erl_client(sftp, _C, Ch, _Id, RootDir) -> + FileName0 = "f0", + F0 = filename:join(RootDir, FileName0), + + %% Create and write a file: + ok = ssh_sftp:write_file(Ch, + F0 = filename:join(RootDir, FileName0), + Data0 = mkbin(1234,240)), + {ok,Data0} = ssh_sftp:read_file(Ch, F0), + {ok, #file_info{type=regular, access=read_write, size=1234}} = ssh_sftp:read_file_info(Ch, F0), + + %% Re-write: + {ok,Handle0} = ssh_sftp:open(Ch, F0, [write,read,binary]), + ok = ssh_sftp:pwrite(Ch, Handle0, 16, Data0_1=mkbin(10,255)), + + <<B1:16/binary, _:10/binary, B2:(1234-26)/binary>> = Data0, + FileContents = <<B1:16/binary, Data0_1:10/binary, B2:(1234-26)/binary>>, + + <<_:1/binary, Part:25/binary, _/binary>> = FileContents, + {ok, Part} = ssh_sftp:pread(Ch, Handle0, 1, 25), + + %% Check: + {ok, FileContents} = ssh_sftp:pread(Ch, Handle0, 0, 1234), + ok = ssh_sftp:close(Ch, Handle0), + + %% Check in another way: + {ok, FileContents} = ssh_sftp:read_file(Ch, F0), + + %% Remove write access rights and check that it can't be written: + ok = ssh_sftp:write_file_info(Ch, F0, #file_info{mode=8#400}), %read}), + {ok, #file_info{type=regular, access=read}} = ssh_sftp:read_file_info(Ch, F0), + {error,permission_denied} = ssh_sftp:write_file(Ch, F0, mkbin(10,14)), + + %% Test deletion of file and dir: + [FileName0] = ok(ssh_sftp:list_dir(Ch, RootDir)) -- [".", ".."], + ok = ssh_sftp:delete(Ch, F0), + [] = ok(ssh_sftp:list_dir(Ch, RootDir)) -- [".", ".."], + ok = ssh_sftp:del_dir(Ch, RootDir), + false = lists:member(RootDir, ok(ssh_sftp:list_dir(Ch, "."))), + ok. + + +wait_for_async_result(Aref) -> + receive + {async_reply, Aref, Result} -> + Result + after + 60000 -> + timeout + end. + + +mkbin(Size, Byte) -> + list_to_binary(lists:duplicate(Size,Byte)). + +ok({ok,X}) -> X. + +%%%---------------------------------------------------------------- +renegotiate_test(init, ConnectionRef) -> + Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), + ssh_connection_handler:renegotiate(ConnectionRef), + %%ct:log("Renegotiate test initiated!",[]), + Kex1; + +renegotiate_test(Kex1, ConnectionRef) -> + case ssh_test_lib:get_kex_init(ConnectionRef) of + Kex1 -> + ct:log("Renegotiate test failed, Kex1 == Kex2!",[]), + error(renegotiate_failed); + _ -> + %% ct:log("Renegotiate test passed!",[]), + ok + end. diff --git a/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-base-image b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-base-image new file mode 100755 index 0000000000..1cb7bf33e1 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-base-image @@ -0,0 +1,38 @@ +#!/bin/sh + +UBUNTU_VER=${1:-16.04} + +USER=sshtester +PWD=foobar + +docker build \ + -t ubuntubuildbase \ + --build-arg https_proxy=$HTTPS_PROXY \ + --build-arg http_proxy=$HTTP_PROXY \ + - <<EOF + + FROM ubuntu:$UBUNTU_VER + WORKDIR /buildroot + + # Prepare for installing OpenSSH + RUN apt-get update + RUN apt-get upgrade -y + RUN apt-get -y install apt-utils + RUN apt-get -y install build-essential zlib1g-dev + RUN apt-get -y install sudo iputils-ping tcptraceroute net-tools + RUN apt-get -y install sshpass expect + RUN apt-get -y install libpam0g-dev + + # A user for the tests + RUN (echo $PWD; echo $PWD; echo; echo; echo; echo; echo; echo ) | adduser $USER + RUN adduser $USER sudo + + # Prepare the privsep preauth environment for openssh + RUN mkdir -p /var/empty + RUN chown root:sys /var/empty + RUN chmod 755 /var/empty + RUN groupadd -f sshd + RUN ls /bin/false + RUN id -u sshd 2> /dev/null || useradd -g sshd -c 'sshd privsep' -d /var/empty -s /bin/false sshd + +EOF diff --git a/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-dropbear-ssh b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-dropbear-ssh new file mode 100755 index 0000000000..85973081d0 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-dropbear-ssh @@ -0,0 +1,28 @@ +#!/bin/sh + +# ./create-dropbear-ssh + +# This way of fetching the tar-file separate from the docker commands makes +# http-proxy handling way easier. The wget command handles the $https_proxy +# variable while the docker command must have /etc/docker/something changed +# and the docker server restarted. That is not possible without root access. + +# Make a Dockerfile. This method simplifies env variable handling considerably: +cat - > TempDockerFile <<EOF + + FROM ubuntubuildbase + + WORKDIR /buildroot + + RUN apt-get -y update + RUN apt-get -y upgrade + RUN apt-get -y install openssh-sftp-server +%% RUN echo 81 | apt-get -y install dropbear + +EOF + +# Build the image: +docker build -t ssh_compat_suite-ssh-dropbear -f ./TempDockerFile . + +# Cleaning +rm -fr ./TempDockerFile $TMP diff --git a/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-dropbear-ssh-run b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-dropbear-ssh-run new file mode 100755 index 0000000000..d98c0cfaa3 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-dropbear-ssh-run @@ -0,0 +1,27 @@ +#!/bin/sh + +# ./create-dropbear-ssh-run + +VER=v2016.72 + +# This way of fetching the tar-file separate from the docker commands makes +# http-proxy handling way easier. The wget command handles the $https_proxy +# variable while the docker command must have /etc/docker/something changed +# and the docker server restarted. That is not possible without root access. + +# Make a Dockerfile. This method simplifies env variable handling considerably: +cat - > TempDockerFile <<EOF + + FROM ssh_compat_suite-ssh-dropbear-installed:${VER} + + WORKDIR /buildroot + + CMD dropbear -F -p 1234 + +EOF + +# Build the image: +docker build -t ssh_compat_suite-ssh:dropbear${VER} -f ./TempDockerFile . + +# Cleaning +rm -fr ./TempDockerFile $TMP diff --git a/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-ssh-image b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-ssh-image new file mode 100755 index 0000000000..2e08408841 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-ssh-image @@ -0,0 +1,72 @@ +#!/bin/sh + +# ./create-image openssh 7.3p1 openssl 1.0.2m + +set -x + +case $1 in + openssh) + FAMssh=openssh + VERssh=$2 + PFX=https://ftp.eu.openbsd.org/pub/OpenBSD/OpenSSH/portable/openssh- + SFX=.tar.gz + TMP=tmp.tar.gz + ;; + *) + echo "Unsupported: $1" + exit +esac + +FAMssl=$3 +VERssl=$4 + +VER=${FAMssh}${VERssh}-${FAMssl}${VERssl} + +# This way of fetching the tar-file separate from the docker commands makes +# http-proxy handling way easier. The wget command handles the $https_proxy +# variable while the docker command must have /etc/docker/something changed +# and the docker server restarted. That is not possible without root access. + +# Make a Dockerfile. This method simplifies env variable handling considerably: +cat - > TempDockerFile <<EOF + + FROM ssh_compat_suite-${FAMssl}:${VERssl} + + LABEL openssh-version=${VER} + + WORKDIR /buildroot + + COPY ${TMP} . + RUN tar xf ${TMP} + + # Build and install + + WORKDIR ${FAMssh}-${VERssh} + + # Probably VERY OpenSSH dependent...: + RUN ./configure --without-pie \ + --prefix=/buildroot/ssh \ + --with-ssl-dir=/buildroot/ssl \ + --with-pam \ + LDFLAGS=-Wl,-R/buildroot/ssl/lib + RUN make + RUN make install + RUN echo UsePAM yes >> /buildroot/ssh/etc/sshd_config + + RUN echo Built ${VER} + + # Start the daemon, but keep it in foreground to avoid killing the container + CMD /buildroot/ssh/sbin/sshd -D -p 1234 + +EOF + +# Fetch the tar file. This could be done in an "ADD ..." in the Dockerfile, +# but then we hit the proxy problem... +wget -O $TMP $PFX$VERssh$SFX + +# Build the image: +docker build -t ssh_compat_suite-ssh:$VER -f ./TempDockerFile . + +# Cleaning +rm -fr ./TempDockerFile $TMP + diff --git a/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-ssl-image b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-ssl-image new file mode 100755 index 0000000000..4ab2a8bddc --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-ssl-image @@ -0,0 +1,71 @@ +#!/bin/sh + +# ./create-image openssl 1.0.2m + +case "$1" in + "openssl") + FAM=openssl + VER=$2 + PFX=https://www.openssl.org/source/openssl- + SFX=.tar.gz + TMP=tmp.tar.gz + ;; + "libressl") + FAM=libressl + VER=$2 + PFX=https://ftp.openbsd.org/pub/OpenBSD/LibreSSL/libressl- + SFX=.tar.gz + TMP=tmp.tar.gz + ;; + *) + echo No lib type + exit + ;; +esac + +case $1$2 in + openssl0.9.8[a-l]) + CONFIG_FLAGS=no-asm + ;; + *) + CONFIG_FLAGS= + ;; +esac + + +# This way of fetching the tar-file separate from the docker commands makes +# http-proxy handling way easier. The wget command handles the $https_proxy +# variable while the docker command must have /etc/docker/something changed +# and the docker server restarted. That is not possible without root access. + +# Make a Dockerfile. This method simplifies env variable handling considerably: +cat - > TempDockerFile <<EOF + + FROM ubuntubuildbase + + LABEL version=$FAM-$VER + + WORKDIR /buildroot + + COPY ${TMP} . + RUN tar xf ${TMP} + + WORKDIR ${FAM}-${VER} + + RUN ./config --prefix=/buildroot/ssl ${CONFIG_FLAGS} + + RUN make + RUN make install_sw + + RUN echo Built ${FAM}-${VER} +EOF + +# Fetch the tar file. This could be done in an "ADD ..." in the Dockerfile, +# but then we hit the proxy problem... +wget -O $TMP $PFX$VER$SFX + +# Build the image: +docker build -t ssh_compat_suite-$FAM:$VER -f ./TempDockerFile . + +# Cleaning +rm -fr ./TempDockerFile $TMP diff --git a/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create_all b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create_all new file mode 100755 index 0000000000..0dcf8cb570 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create_all @@ -0,0 +1,89 @@ +#!/bin/bash + +UBUNTU_VERSION=16.04 + +SSH_SSL_VERSIONS=(\ + openssh 4.4p1 openssl 0.9.8c \ + openssh 4.5p1 openssl 0.9.8m \ + openssh 5.0p1 openssl 0.9.8za \ + openssh 6.2p2 openssl 0.9.8c \ + openssh 6.3p1 openssl 0.9.8zh \ + \ + openssh 7.1p1 openssl 1.0.0a \ + \ + openssh 7.1p1 openssl 1.0.1p \ + \ + openssh 6.6p1 openssl 1.0.2n \ + openssh 7.1p1 openssl 1.0.2n \ + openssh 7.6p1 openssl 1.0.2n \ + \ + openssh 7.6p1 libressl 2.6.4 \ + ) + +if [ "x$1" == "x-b" ] +then + shift + SKIP_CREATE_BASE=true +fi + +WHAT_TO_DO=$1 + +function create_one_image () +{ + SSH_FAM=$1 + SSH_VER=$2 + SSL_FAM=$3 + SSL_VER=$4 + + [ "x$SKIP_CREATE_BASE" == "xtrue" ] || ./create-base-image || (echo "Create base failed." >&2; exit 1) + ./create-ssl-image $SSL_FAM $SSL_VER \ + || (echo "Create $SSL_FAM $SSL_VER failed." >&2; exit 2) + + ./create-ssh-image $SSH_FAM $SSH_VER $SSL_FAM $SSL_VER \ + || (echo "Create $SSH_FAM $SSH_VER on $SSL_FAM $SSL_VER failed." >&2; exit 3) +} + + +case ${WHAT_TO_DO} in + list) + ;; + listatoms) + PRE="[" + POST="]" + C=\' + COMMA=, + ;; + build_one) + if [ $# != 5 ] + then + echo "$0 build_one openssh SSH_ver openssl SSL_ver " && exit + else + create_one_image $2 $3 $4 $5 + exit + fi + ;; + build_all) + ;; + *) + echo "$0 [-b] list | listatoms | build_one openssh SSH_ver openssl SSL_ver | build_all" && exit + ;; +esac + + +echo -n $PRE +i=0 +while [ "x${SSH_SSL_VERSIONS[i]}" != "x" ] +do + case ${WHAT_TO_DO} in + list*) + [ $i -eq 0 ] || echo $COMMA + echo -n $C${SSH_SSL_VERSIONS[$i]}${SSH_SSL_VERSIONS[$(( $i + 1 ))]}-${SSH_SSL_VERSIONS[$(( $i + 2 ))]}${SSH_SSL_VERSIONS[$(( $i + 3 ))]}$C + ;; + build_all) + create_one_image ${SSH_SSL_VERSIONS[$i]} ${SSH_SSL_VERSIONS[$(( $i + 1 ))]} ${SSH_SSL_VERSIONS[$(( $i + 2 ))]} ${SSH_SSL_VERSIONS[$(( $i + 3 ))]} + ;; + esac + + i=$(( $i + 4 )) +done +echo $POST diff --git a/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_dsa_key b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_dsa_key new file mode 100644 index 0000000000..8b2354a7ea --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_dsa_key @@ -0,0 +1,12 @@ +-----BEGIN DSA PRIVATE KEY----- +MIIBugIBAAKBgQDlXDEddxFbTtPsu2bRTbSONFVKMxe430iqBoXoKK2Gyhlqn7J8 +SRGlmvTN7T06+9iFqgJi+x+dlSJGlNEY/v67Z8C7rWfJynYuRier4TujLwP452RT +YrsnCq47pGJXHb9xAWr7UGMv85uDrECUiIdK4xIrwpW/gMb5zPSThDGNiwIVANts +B9nBX0NH/B0lXthVCg2jRSkpAoGAIS3vG8VmjQNYrGfdcdvQtGubFXs4jZJO6iDe +9u9/O95dcnH4ZIL4y3ZPHbw73dCKXFe5NlqI/POmn3MyFdpyqH5FTHWB/aAFrma6 +qo00F1mv83DkQCEfg6fwE/SaaBjDecr5I14hWOtocpYqlY1/x1aspahwK6NLPp/D +A4aAt78CgYAmNgr3dnHgMXrEsAeHswioAad3YLtnPvdFdHqd5j4oSbgKwFd7Xmyq +blfeQ6rRo8dmUF0rkUU8cn71IqbhpsCJQEZPt9WBlhHiY95B1ELKYHoHCbZA8qrZ +iEIcfwch85Da0/uzv4VE0UHTC0P3WRD3sZDfXd9dZLdc80n6ImYRpgIURgW8SZGj +X0mMkMJv/Ltdt0gYx60= +-----END DSA PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_dsa_key.pub b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_dsa_key.pub new file mode 100644 index 0000000000..9116493472 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_dsa_key.pub @@ -0,0 +1 @@ +ssh-dss AAAAB3NzaC1kc3MAAACBAOVcMR13EVtO0+y7ZtFNtI40VUozF7jfSKoGhegorYbKGWqfsnxJEaWa9M3tPTr72IWqAmL7H52VIkaU0Rj+/rtnwLutZ8nKdi5GJ6vhO6MvA/jnZFNiuycKrjukYlcdv3EBavtQYy/zm4OsQJSIh0rjEivClb+AxvnM9JOEMY2LAAAAFQDbbAfZwV9DR/wdJV7YVQoNo0UpKQAAAIAhLe8bxWaNA1isZ91x29C0a5sVeziNkk7qIN7273873l1ycfhkgvjLdk8dvDvd0IpcV7k2Woj886afczIV2nKofkVMdYH9oAWuZrqqjTQXWa/zcORAIR+Dp/AT9JpoGMN5yvkjXiFY62hyliqVjX/HVqylqHAro0s+n8MDhoC3vwAAAIAmNgr3dnHgMXrEsAeHswioAad3YLtnPvdFdHqd5j4oSbgKwFd7XmyqblfeQ6rRo8dmUF0rkUU8cn71IqbhpsCJQEZPt9WBlhHiY95B1ELKYHoHCbZA8qrZiEIcfwch85Da0/uzv4VE0UHTC0P3WRD3sZDfXd9dZLdc80n6ImYRpg== uabhnil@elxadlj3q32 diff --git a/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key256 b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key256 new file mode 100644 index 0000000000..5ed2b361cc --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key256 @@ -0,0 +1,5 @@ +-----BEGIN EC PRIVATE KEY----- +MHcCAQEEILwQIf+Jul+oygeJn7cBSvn2LGqnW1ZfiHDQMDXZ96mooAoGCCqGSM49 +AwEHoUQDQgAEJUo0gCIhXEPJYvxec23IAjq7BjV1xw8deI8JV9vL5BMCZNhyj5Vt +NbFPbKPuL/Sikn8p4YP/5y336ug7szvYrg== +-----END EC PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key256.pub b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key256.pub new file mode 100644 index 0000000000..240387d901 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key256.pub @@ -0,0 +1 @@ +ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBCVKNIAiIVxDyWL8XnNtyAI6uwY1dccPHXiPCVfby+QTAmTYco+VbTWxT2yj7i/0opJ/KeGD/+ct9+roO7M72K4= uabhnil@elxadlj3q32 diff --git a/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key384 b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key384 new file mode 100644 index 0000000000..9d31d75cd5 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key384 @@ -0,0 +1,6 @@ +-----BEGIN EC PRIVATE KEY----- +MIGkAgEBBDBw+P1sic2i41wTGQgjyUlBtxQfnY77L8TFcDngoRiVrbCugnDrioNo +JogqymWhSC+gBwYFK4EEACKhZANiAATwaqEp3vyLzfb08kqgIZLv/mAYJyGD+JMt +f11OswGs3uFkbHZOErFCgeLuBvarSTAFkOlMR9GZGaDEfcrPBTtvKj+jEaAvh6yr +JxS97rtwk2uadDMem2x4w9Ga4jw4S8E= +-----END EC PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key384.pub b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key384.pub new file mode 100644 index 0000000000..cca85bda72 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key384.pub @@ -0,0 +1 @@ +ecdsa-sha2-nistp384 AAAAE2VjZHNhLXNoYTItbmlzdHAzODQAAAAIbmlzdHAzODQAAABhBPBqoSne/IvN9vTySqAhku/+YBgnIYP4ky1/XU6zAaze4WRsdk4SsUKB4u4G9qtJMAWQ6UxH0ZkZoMR9ys8FO28qP6MRoC+HrKsnFL3uu3CTa5p0Mx6bbHjD0ZriPDhLwQ== uabhnil@elxadlj3q32 diff --git a/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key521 b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key521 new file mode 100644 index 0000000000..b698be1ec9 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key521 @@ -0,0 +1,7 @@ +-----BEGIN EC PRIVATE KEY----- +MIHcAgEBBEIBtGVvyn7kGX7BfWAYHK2ZXmhWscTOV0J0mAfab0u0ZMw0id2a3O9s +sBjJoCqoAXTJ7d/OUw85qqQNDE5GDQpDFq6gBwYFK4EEACOhgYkDgYYABAHPWfUD +tQ/JmfwmmSdWWjGm94hFqwaivI4H43acDdd71+vods4rN2Yh3X7fSUvJkeOhXFOJ +yO9F+61ssKgS0a0nxQEvdXks3QyfKTPjYQuBUvY+AV/A4AskPBz731xCDmbYuWuh +RPekZ7d5bF0U0pGlExbX+naQJMSbJSdZrPM9993EmA== +-----END EC PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key521.pub b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key521.pub new file mode 100644 index 0000000000..d181d30d69 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_ecdsa_key521.pub @@ -0,0 +1 @@ +ecdsa-sha2-nistp521 AAAAE2VjZHNhLXNoYTItbmlzdHA1MjEAAAAIbmlzdHA1MjEAAACFBAHPWfUDtQ/JmfwmmSdWWjGm94hFqwaivI4H43acDdd71+vods4rN2Yh3X7fSUvJkeOhXFOJyO9F+61ssKgS0a0nxQEvdXks3QyfKTPjYQuBUvY+AV/A4AskPBz731xCDmbYuWuhRPekZ7d5bF0U0pGlExbX+naQJMSbJSdZrPM9993EmA== uabhnil@elxadlj3q32 diff --git a/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_rsa_key b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_rsa_key new file mode 100644 index 0000000000..84096298ca --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_rsa_key @@ -0,0 +1,27 @@ +-----BEGIN RSA PRIVATE KEY----- +MIIEpAIBAAKCAQEAuC6uxC0P8voYQCrwJzczo9iSiwsovPv4etd2BLnu8cKWdnjR +34tWvtguw2kO+iDyt4hFGGfDBQf2SXl+ZEsE2N1RlSp5A73me2byw/L4MreX2rbU +TwyNXF3TBvKb3Gbpx7PoiB9frcb9RCMxtypBvGQD6bx6h5UWKuSkYzARaRLv3kbB +swcqfrA3PfWybkIoaa2RO1Ca86u6K0v+a4r0OfRxTnghuakZkH6CD7+uU3irliPI +UFt2wTI/qWmnDrMFh4RffToHK0QZHXdkq4ama5kRZdZ0svSorxqkl8EWGPhReoUj +Yrz0bCNevSlDxHCxLi8epRxuv+AhZHW0YdMCCwIDAQABAoIBAHUyj1aZbfqolWHP +cL0jbSKnHqiHU0bd9sED9T8QqTEBJwj/3Fwop+wMV8VURol3CbsrZPwgmoHLDTa3 +rmtXKSBtxAns2tA8uDpxyaxSIQj0thYgHHyoehL6SNu06OSYP84pdp+XhyRm6KXA +11O7+dRMuAi1PCql/VMR5mCPJ6T5qWAVYHFyEBvMm4q5yYSRSPaAaZHC6WbEsxHN +jGzcyl3tvmOyN0+M7v0U86lQ+H2tSXH+nQg/Ig6hWgFGg8AYoos/9yUGOY+e9bUE +serYdsuiyxBfo4CgoSeDsjwNp1lAZ5UOrIDdRqK9C8jGVkHDzwfmmtczWXkVVzGZ +Bd05izECgYEA31yHzSA/umamyZAQbi/5psk1Fc5m6MzsgmJmB6jm7hUZ0EbpSV4C +6b1nOrk/IAtA12rvDHgWy0zpkJbC5b03C77RnBgTRgLQyolrcpLDJ47+Kxf/AHGk +m63KaCpwZEQ4f9ARBXySD/jNoW9gz5S6Xa3RnHOC70DsIIk5VOCjWk0CgYEA0xiM +Ay27PJcbAG/4tnjH8DZfHb8SULfnfUj8kMe3V2SDPDWbhY8zheo45wTBDRflFU5I +XyGmfuZ7PTTnFVrJz8ua3mAMOzkFn4MmdaRCX9XtuE4YWq3lFvxlrJvfXSjEL0km +8UwlhJMixaEPqFQjsKc9BHwWKRiKcF4zFQ1DybcCgYB46yfdhYLaj23lmqc6b6Bw +iWbCql2N1DqJj2l65hY2d5fk6C6s+EcNcOrsoJKq70yoEgzdrDlyz+11yBg0tU2S +fzgMkAAHG8kajHBts0QRK1kvzSrQe7VITjpQUAFOVpxbnTFJzhloqiHwLlKzremC +g3IBh4svqO7r4j32VDI61QKBgQCQL4gS872cWSncVp7vI/iNHtZBHy2HbNX1QVEi +Iwgb7U+mZIdh5roukhlj0l96bgPPVbUhJX7v1sX+vI/KikSmZk/V7IzuNrich5xR +ZmzfwOOqq8z+wyBjXuqjx6P9oca+9Zxf3L8Tmtx5WNW1CCOImfKXiZopX9XPgsgp +bPIMaQKBgQCql4uTSacSQ5s6rEEdvR+y6nTohF3zxhOQ+6xivm3Hf1mgTk40lQ+t +sr6HsSTv8j/ZbhhtaUUb2efro3pDztjlxXFvITar9ZDB2B4QMlpSsDR9UNk8xKGY +J9aYLr4fJC6J6VA7Wf0yq6LpjSXRH/2GeNtmMl5rFRsHt+VU7GZK9g== +-----END RSA PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_rsa_key.pub b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_rsa_key.pub new file mode 100644 index 0000000000..4ac6e7b124 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/host_keys/ssh_host_rsa_key.pub @@ -0,0 +1 @@ +ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC4Lq7ELQ/y+hhAKvAnNzOj2JKLCyi8+/h613YEue7xwpZ2eNHfi1a+2C7DaQ76IPK3iEUYZ8MFB/ZJeX5kSwTY3VGVKnkDveZ7ZvLD8vgyt5fattRPDI1cXdMG8pvcZunHs+iIH1+txv1EIzG3KkG8ZAPpvHqHlRYq5KRjMBFpEu/eRsGzByp+sDc99bJuQihprZE7UJrzq7orS/5rivQ59HFOeCG5qRmQfoIPv65TeKuWI8hQW3bBMj+paacOswWHhF99OgcrRBkdd2SrhqZrmRFl1nSy9KivGqSXwRYY+FF6hSNivPRsI169KUPEcLEuLx6lHG6/4CFkdbRh0wIL uabhnil@elxadlj3q32 diff --git a/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_dsa b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_dsa new file mode 100644 index 0000000000..01a88acea2 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_dsa @@ -0,0 +1,12 @@ +-----BEGIN DSA PRIVATE KEY----- +MIIBvAIBAAKBgQC97XncQDaa9PQYEWK7llBxZQ2suVYTz1eadw2HtY+Y8ZKdUBLd +9LUQ2lymUC9yq66rb5pBBR13k/9Zcbu8I0nafrZT4wJ4H0YGD6Ob5O4HR4EHjO5q +hgnMJ17e1XnzI31MW5xAuAHTLLClNvnG05T1jaU+tRAsVSCHin3+sOenowIVAMSe +ANBvw7fm5+Lw+ziOAHPjeYzRAoGBALkWCGpKmlJ65F3Y/RcownHQvsrDAllzKF/a +cSfriCVVP5qVZ3Ach28ZZ9BFEnRE2SKqVsyBAiceb/+ISlu8CqKEvvoNIMJAu5rU +MwZh+PeHN4ES6tWTwBGAwu84ke6N4BgV+6Q4qkcyywHsT5oU0EdVbn2zzAZw8c7v +BpbsJ1KsAoGABraHWqSFhaX4+GHmtKwXZFVRKh/4R6GR2LpkFzGm3Ixv+eo9K5CI +TjiBYiVMrWH23G1LiDuJyMGqHEnIef+sorNfNzdnwq+8qRCTS6mbpRXkUt9p1arJ +MIKmosS+GFhTN6Z85gCwC51S2EDC4GW7J4ViHKacr1FwJSw9RC9F+WsCFQCRJayH +P4vM1XUOVEeX7u04K1EAFg== +-----END DSA PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_dsa.pub b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_dsa.pub new file mode 100644 index 0000000000..30661d5adf --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_dsa.pub @@ -0,0 +1 @@ +ssh-dss AAAAB3NzaC1kc3MAAACBAL3tedxANpr09BgRYruWUHFlDay5VhPPV5p3DYe1j5jxkp1QEt30tRDaXKZQL3KrrqtvmkEFHXeT/1lxu7wjSdp+tlPjAngfRgYPo5vk7gdHgQeM7mqGCcwnXt7VefMjfUxbnEC4AdMssKU2+cbTlPWNpT61ECxVIIeKff6w56ejAAAAFQDEngDQb8O35ufi8Ps4jgBz43mM0QAAAIEAuRYIakqaUnrkXdj9FyjCcdC+ysMCWXMoX9pxJ+uIJVU/mpVncByHbxln0EUSdETZIqpWzIECJx5v/4hKW7wKooS++g0gwkC7mtQzBmH494c3gRLq1ZPAEYDC7ziR7o3gGBX7pDiqRzLLAexPmhTQR1VufbPMBnDxzu8GluwnUqwAAACABraHWqSFhaX4+GHmtKwXZFVRKh/4R6GR2LpkFzGm3Ixv+eo9K5CITjiBYiVMrWH23G1LiDuJyMGqHEnIef+sorNfNzdnwq+8qRCTS6mbpRXkUt9p1arJMIKmosS+GFhTN6Z85gCwC51S2EDC4GW7J4ViHKacr1FwJSw9RC9F+Ws= uabhnil@elxadlj3q32 diff --git a/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa new file mode 100644 index 0000000000..60e8f6eb6e --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa @@ -0,0 +1,5 @@ +-----BEGIN EC PRIVATE KEY----- +MHcCAQEEIC557KPgmq+pWOAh1L8DV8GWW0u7W5vz6mim3FFB1l8koAoGCCqGSM49 +AwEHoUQDQgAEC3J5fQ8+8xQso0lhBdoLdvD14oSsQiMuweXq+Dy2+4Mjdw2/bbw0 +CvbE2+KWNcgwxRLycNGcMCBdf/cOgNyGkA== +-----END EC PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa256 b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa256 new file mode 100644 index 0000000000..60e8f6eb6e --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa256 @@ -0,0 +1,5 @@ +-----BEGIN EC PRIVATE KEY----- +MHcCAQEEIC557KPgmq+pWOAh1L8DV8GWW0u7W5vz6mim3FFB1l8koAoGCCqGSM49 +AwEHoUQDQgAEC3J5fQ8+8xQso0lhBdoLdvD14oSsQiMuweXq+Dy2+4Mjdw2/bbw0 +CvbE2+KWNcgwxRLycNGcMCBdf/cOgNyGkA== +-----END EC PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa256.pub b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa256.pub new file mode 100644 index 0000000000..b349d26da3 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa256.pub @@ -0,0 +1 @@ +ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBAtyeX0PPvMULKNJYQXaC3bw9eKErEIjLsHl6vg8tvuDI3cNv228NAr2xNviljXIMMUS8nDRnDAgXX/3DoDchpA= sshtester@elxadlj3q32 diff --git a/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa384 b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa384 new file mode 100644 index 0000000000..ece6c8f284 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa384 @@ -0,0 +1,6 @@ +-----BEGIN EC PRIVATE KEY----- +MIGkAgEBBDBdgJs/xThHiy/aY1ymtQ4B0URNnRCm8l2WZMFjua57+nvq4Duf+igN +pN/5p/+azLKgBwYFK4EEACKhZANiAATUw6pT/UW2HvTW6lL2BGY7NfUGEX285XVi +9AcTXH1K+TOekbGmcpSirlGzSb15Wycajpmaae5vAzH1nnvcVd3FYODVdDXTHgV/ +FeXQ+vaw7CZnEAKZsr8mjXRX3fEyO1E= +-----END EC PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa384.pub b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa384.pub new file mode 100644 index 0000000000..fd81e220f7 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa384.pub @@ -0,0 +1 @@ +ecdsa-sha2-nistp384 AAAAE2VjZHNhLXNoYTItbmlzdHAzODQAAAAIbmlzdHAzODQAAABhBNTDqlP9RbYe9NbqUvYEZjs19QYRfbzldWL0BxNcfUr5M56RsaZylKKuUbNJvXlbJxqOmZpp7m8DMfWee9xV3cVg4NV0NdMeBX8V5dD69rDsJmcQApmyvyaNdFfd8TI7UQ== uabhnil@elxadlj3q32 diff --git a/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa521 b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa521 new file mode 100644 index 0000000000..21c000ea03 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa521 @@ -0,0 +1,7 @@ +-----BEGIN EC PRIVATE KEY----- +MIHbAgEBBEEhm0w3xcGILU8eP61mThVBwCJfyzrFktGf7cCa1ciL4YLsukd20Q3Z +yp0YcEDLcEm36CZGabgkEvblJ1Rx2lPTu6AHBgUrgQQAI6GBiQOBhgAEAYep8cX2 +7wUPw5pNYwFkWQXrJ2GSkmO8iHwkWJ6srRay/sF3WoPF/dyDVymFgirtsSTJ+D0u +ex4qphOOJxkd1Yf+ANHvDFN9LoBvbgtNLTRJlpuNLCdWQlt+mEnPMDGMV/HWHHiz +7/mWE+XUVIcQjhm5uv0ObI/wroZEurXMGEhTis3L +-----END EC PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa521.pub b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa521.pub new file mode 100644 index 0000000000..d9830da5de --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_ecdsa521.pub @@ -0,0 +1 @@ +ecdsa-sha2-nistp521 AAAAE2VjZHNhLXNoYTItbmlzdHA1MjEAAAAIbmlzdHA1MjEAAACFBAGHqfHF9u8FD8OaTWMBZFkF6ydhkpJjvIh8JFierK0Wsv7Bd1qDxf3cg1cphYIq7bEkyfg9LnseKqYTjicZHdWH/gDR7wxTfS6Ab24LTS00SZabjSwnVkJbfphJzzAxjFfx1hx4s+/5lhPl1FSHEI4Zubr9DmyP8K6GRLq1zBhIU4rNyw== uabhnil@elxadlj3q32 diff --git a/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_rsa b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_rsa new file mode 100644 index 0000000000..2e50ac2304 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_rsa @@ -0,0 +1,27 @@ +-----BEGIN RSA PRIVATE KEY----- +MIIEpQIBAAKCAQEA7+C3gLoflKybq4I+clbg2SWf6cXyHpnLNDnZeMvIbOz2X/Ce +XUm17DFeexTaVBs9Zq9WwDFOFkLQhbuXgpvB0shSY0nr+Em7InRM8AiRLxPe0txM +mFFhL+v083dYwgaJOo1PthNM/tGRZJu+0sQDqrmN7CusFHdZg2NTzTzbwWqPiuP/ +mf3o7W4CWqDTBzbYTgpWlH7vRZf9FYwT4on5YWzLA8TvO2TwBGTfTMK5nswH++iO +v4jKecoEwyBFMUSKqZ9UYHGw/kshHbltM65Ye/xjXEX0GxDdxu8ZyVKXd4acNbJJ +P0tcxN4GzKJiR6zNYwCzDhjqDEbM5qCGhShhgQIDAQABAoIBAQCucdGBP9mvmUcs +Fu+q3xttTztYGqfVMSrhtCA/BJOhA0K4ypegZ/Zw6gY3pBaSi6y/fEuuQSz0a2qR +lra8OOFflGa15hBA4/2/NKyu8swCXITy+1qIesYev43HcMePcolhl1qcorSfq2/8 +pnbDd+Diy0Y2thvSVmk2b4mF+/gkUx3CHLhgRMcxCHLG1VeqIfLf+pa0jIw94tZ5 +CoIoI096pDTsneO9xhh1QxWQRRFVqdf3Q9zyiBgJCggpX+1fVsbQejuEK4hKRBKx +SRPX/pX5aU+7+KSZ/DbtXGg1sCw9NUDFTIEV3UPmko4oWawNGv/CQAK80g3go28v +UnVf11BBAoGBAP2amIFp+Ps33A5eesT7g/NNkGqBEi5W37K8qzYJxqXJvH0xmpFo +8a3Je3PQRrzbTUJyISA6/XNnA62+bEvWiEXPiK3stQzNHoVz7ftCb19zgW4sLKRW +Qhjq7QsGeRrdksJnZ7ekfzOv658vHJPElS1MdPu2WWhiNvAjtmdyFQulAoGBAPIk +6831QAnCdp/ffH/K+cqV9vQYOFig8n4mQNNC+sLghrtZh9kbmTuuNKAhF56vdCCn +ABD/+RiLXKVsF0PvQ5g9wRLKaiJubXI7XEBemCCLhjtESxGpWEV8GalslUgE1cKs +d1pwSVjd0sYt0gOAf2VRhlbpSWhXA2xVll34xgetAoGAHaI089pYN7K9SgiMO/xP +3NxRZcCTSUrpdM9LClN2HOVH2zEyqI8kvnPuswfBXEwb6QnBCS0bdKKy8Vhw+yOk +ZNPtWrVwKoDFcj6rrlKDBRpQI3mR9doGezboYANvn04I2iKPIgxcuMNzuvQcWL/9 +1n86pDcYl3Pyi3kA1XGlN+kCgYEAz1boBxpqdDDsjGa8X1y5WUviAw8+KD3ghj5R +IdTnjbjeBUxbc38bTawUac0MQZexE0iMWQImFGs4sHkGzufwdErkqSdjjAoMc1T6 +4C9fifaOwO7wbLYZ3J2wB4/vn5RsSV6OcIVXeN2wXnvbqZ38+A+/vWnSrqJbTwdW +Uy7yup0CgYEA8M9vjpAoCr3XzNDwJyWRQcT7e+nRYUNDlXBl3jpQhHuJtnSnkoUv +HXYXEwvp8peycNzeVz5OwFVMzCH8OG4WiGN4Pmo0rDWHED/W7eIRHIitHGTzZ+Qw +gRxscoewblSLSkYMXidBLmQjr4U5bDBesRuGhm5NuLyMTa1f3Pc/90k= +-----END RSA PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_rsa.pub b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_rsa.pub new file mode 100644 index 0000000000..26e560d4f8 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/users_keys/id_rsa.pub @@ -0,0 +1 @@ +ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQDv4LeAuh+UrJurgj5yVuDZJZ/pxfIemcs0Odl4y8hs7PZf8J5dSbXsMV57FNpUGz1mr1bAMU4WQtCFu5eCm8HSyFJjSev4SbsidEzwCJEvE97S3EyYUWEv6/Tzd1jCBok6jU+2E0z+0ZFkm77SxAOquY3sK6wUd1mDY1PNPNvBao+K4/+Z/ejtbgJaoNMHNthOClaUfu9Fl/0VjBPiiflhbMsDxO87ZPAEZN9MwrmezAf76I6/iMp5ygTDIEUxRIqpn1RgcbD+SyEduW0zrlh7/GNcRfQbEN3G7xnJUpd3hpw1skk/S1zE3gbMomJHrM1jALMOGOoMRszmoIaFKGGB uabhnil@elxadlj3q32 diff --git a/lib/ssh/test/ssh_connection_SUITE.erl b/lib/ssh/test/ssh_connection_SUITE.erl index 9bbd9da817..ba4518cfe6 100644 --- a/lib/ssh/test/ssh_connection_SUITE.erl +++ b/lib/ssh/test/ssh_connection_SUITE.erl @@ -91,7 +91,7 @@ end_per_suite(Config) -> init_per_group(openssh, Config) -> case ssh_test_lib:gen_tcp_connect("localhost", 22, []) of {error,econnrefused} -> - {skip,"No openssh deamon"}; + {skip,"No openssh deamon (econnrefused)"}; {ok, Socket} -> gen_tcp:close(Socket), ssh_test_lib:openssh_sanity_check(Config) diff --git a/lib/ssh/test/ssh_engine_SUITE.erl b/lib/ssh/test/ssh_engine_SUITE.erl new file mode 100644 index 0000000000..daf93891e9 --- /dev/null +++ b/lib/ssh/test/ssh_engine_SUITE.erl @@ -0,0 +1,140 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2008-2017. 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(ssh_engine_SUITE). + +-include_lib("common_test/include/ct.hrl"). +-include("ssh_test_lib.hrl"). + +%% Note: This directive should only be used in test suites. +-compile(export_all). + +%%-------------------------------------------------------------------- +%% Common Test interface functions ----------------------------------- +%%-------------------------------------------------------------------- + +suite() -> + [{ct_hooks,[ts_install_cth]}, + {timetrap,{seconds,40}}]. + +all() -> + [{group, dsa_key}, + {group, rsa_key} + ]. + +groups() -> + [{dsa_key, [], basic_tests()}, + {rsa_key, [], basic_tests()} + ]. + +basic_tests() -> + [simple_connect + ]. + + +%%-------------------------------------------------------------------- +init_per_suite(Config) -> + ssh:start(), + ?CHECK_CRYPTO( + case load_engine() of + {ok,E} -> + [{engine,E}|Config]; + {error, notsup} -> + {skip, "Engine not supported on this OpenSSL version"}; + {error, bad_engine_id} -> + {skip, "Dynamic Engine not supported"}; + Other -> + ct:log("Engine load failed: ~p",[Other]), + {fail, "Engine load failed"} + end + ). + +end_per_suite(Config) -> + catch crypto:engine_unload( proplists:get_value(engine,Config) ), + ssh:stop(). + +%%-------------------------------------------------------------------- +init_per_group(dsa_key, Config) -> + case lists:member('ssh-dss', + ssh_transport:default_algorithms(public_key)) of + true -> + start_daemon(Config, 'ssh-dss', "dsa_private_key.pem"); + false -> + {skip, unsupported_pub_key} + end; +init_per_group(rsa_key, Config) -> + case lists:member('ssh-rsa', + ssh_transport:default_algorithms(public_key)) of + true -> + start_daemon(Config, 'ssh-rsa', "rsa_private_key.pem"); + false -> + {skip, unsupported_pub_key} + end. + +start_daemon(Config, KeyType, KeyId) -> + SystemDir = proplists:get_value(data_dir, Config), + FullKeyId = filename:join(SystemDir, KeyId), + KeyCBOpts = [{engine, proplists:get_value(engine,Config)}, + {KeyType, FullKeyId} + ], + Opts = [{key_cb, {ssh_key_cb_engine_keys, KeyCBOpts}}], + {Pid, Host, Port} = ssh_test_lib:std_daemon(Config, Opts), + [{host_port,{Host,Port}}, {daemon_pid,Pid}| Config]. + + +end_per_group(_, Config) -> + catch ssh:stop_daemon(proplists:get_value(daemon_pid,Config)), + Config. + +%%-------------------------------------------------------------------- +%% Test Cases -------------------------------------------------------- +%%-------------------------------------------------------------------- + +%% A simple exec call +simple_connect(Config) -> + {Host,Port} = proplists:get_value(host_port, Config), + CRef = ssh_test_lib:std_connect(Config, Host, Port, []), + ssh:close(CRef). + +%%-------------------------------------------------------------------- +%%-------------------------------------------------------------------- +load_engine() -> + case crypto:get_test_engine() of + {ok, Engine} -> + try crypto:engine_load(<<"dynamic">>, + [{<<"SO_PATH">>, Engine}, + <<"LOAD">>], + []) + catch + error:notsup -> + {error, notsup} + end; + + {error, Error} -> + {error, Error} + end. + +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]. diff --git a/lib/ssh/test/ssh_engine_SUITE_data/dsa_private_key.pem b/lib/ssh/test/ssh_engine_SUITE_data/dsa_private_key.pem new file mode 100644 index 0000000000..778ffac675 --- /dev/null +++ b/lib/ssh/test/ssh_engine_SUITE_data/dsa_private_key.pem @@ -0,0 +1,9 @@ +-----BEGIN PRIVATE KEY----- +MIIBSwIBADCCASwGByqGSM44BAEwggEfAoGBAMyitTMR7vPbpqyAXJpqnB0AhFwQ +F87IE+JKFl5bD/MSkhhRV5sM73HUU1ooXY0FjhZ+cdLUCATuZR5ta4ydANqWIcAB +gX3IwF1B4zf5SXEKTWkUYneL9dOKtiZLtoG28swrk8xMxwX+0fLHkltCEj6FiTW9 +PFrv8GmIfV6DjcI9AhUAqXWbb3RtoN9Ld28fVMhGZrj3LJUCgYEAwnxGHGBMpJaF +2w7zAw3jHjL8PMYlV6vnufGHQlwF0ZUXJxRsvagMb/X1qACTu2VPYEVoLQGM3cfH +EhHoQmvSXGAyTfR7Bmn3gf1n/s/DcFbdZduUCZ/rAyIrfd0eSbc1I+kZk85UCsKK +w/IYdlqcuYa4Cgm2TapT5uEMqH4jhzEEFgIULh8swEUWmU8aJNWsrWl4eCiuUUg= +-----END PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_engine_SUITE_data/ecdsa_private_key.pem b/lib/ssh/test/ssh_engine_SUITE_data/ecdsa_private_key.pem new file mode 100644 index 0000000000..a45522064f --- /dev/null +++ b/lib/ssh/test/ssh_engine_SUITE_data/ecdsa_private_key.pem @@ -0,0 +1,8 @@ +-----BEGIN PRIVATE KEY----- +MIHuAgEAMBAGByqGSM49AgEGBSuBBAAjBIHWMIHTAgEBBEIBparGjr0KcdNrVM2J +G0mW5ltP1QyvxDqBMyWLWo3fruRZv6Qoohl5skd1u4O+KJoM/UrrSTOXI/MDR7NN +i1yl7O+hgYkDgYYABAG8K2XVsK0ahG9+HIIPwCO0pJY8ulwSTXwIjkCGyB2lpglh +8qJmRzuyGcfRTslv8wfv0sPlT9H9PKDvgrTUL7rvQQDdOODNgVPXSecUoXoPn+X+ +eqxs77bjx+A5x0t/i3m5PfkaNPh5MZ1H/bWuOOdj2ZXZw0R4rlVc0zVrgnPU8L8S +BQ== +-----END PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_engine_SUITE_data/rsa_private_key.pem b/lib/ssh/test/ssh_engine_SUITE_data/rsa_private_key.pem new file mode 100644 index 0000000000..ea0e3d3958 --- /dev/null +++ b/lib/ssh/test/ssh_engine_SUITE_data/rsa_private_key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvwIBADANBgkqhkiG9w0BAQEFAASCBKkwggSlAgEAAoIBAQCwwb0/ddXGXTFK +4FLxXdV6a/WJMSoPPS55RvZIAHFsiTtvPLbJ8LxDsZ6wSVZLN0/UQ4wdWn9jftyj +U5/IxBVG8XOtKimTMvm3/ZOzVLueGHBbrLYscRv9oL85ulTKHWgrZDu0lBX5JJTI +v5UTCErzJRQbka9DG1GaBgDb1PlXfkzBWMwfsBZmwoC77KvCcIGCgbW/XCY03TP2 +3Tg8drvpByMStddP2FQ4fZ91qFUzPu8uhZEsqSQTFlmhgGEx7dLlky0xvu62RuAD +RTpINpcWZtWDHTdssOqu653LwwqBY8lBopCZ/4Af8QR3ZYkQhen1YLEbVheXRuzI +LSCZIiJNAgMBAAECggEBAJH4/fxpqQkvr2Shy33Pu1xlyhnpw01gfn/jrcKasxEq +aC4eWup86E2TY3U8q4pkfIXU3uLi+O9HNpmflwargNLc1mY8uqb44ygiv5bLNEKE +9k2PXcdoBfC4jxPyoNFl5cBn/7LK1TazEjiTl15na9ZPWcLG1pG5/vMPYCgsQ1sP +8J3c4E3aaXIj9QceYxBprl490OCzieGyZlRipncz3g4UShRc/b4cycvDZOJpmAy4 +zbWTcBcSMPVPi5coF0K8UcimiqZkotfb/2RLc433i34IdsIXMM+brdq+g8rmjg5a ++oQPy02M6tFApBruEhAz8DGgaLtDY6MLtyZAt3SjXnUCgYEA1zLgamdTHOqrrmIi +eIQBnAJiyIfcY8B9SX1OsLGYFCHiPVwgUY35B2c7MavMsGcExJhtE+uxU7o5djtM +R6r9cRHOXJ6EQwa8OwzzPqbM17/YqNDeK39bc9WOFUqRWrhDhVMPy6z8rmZr73mG +IUC7mBNx/1GBdVYXIlsXzC96dI8CgYEA0kUAhz6I5nyPa70NDEUYHLHf3IW1BCmE +UoVbraSePJtIEY/IqFx7oDuFo30d4n5z+8ICCtyid1h/Cp3mf3akOiqltYUfgV1G +JgcEjKKYWEnO7cfFyO7LB7Y3GYYDJNy6EzVWPiwTGk9ZTfFJEESmHC45Unxgd17m +Dx/R58rFgWMCgYBQXQWFdtSI5fH7C1bIHrPjKNju/h2FeurOuObcAVZDnmu4cmD3 +U8d9xkVKxVeJQM99A1coq0nrdI3k4zwXP3mp8fZYjDHkPe2pN6rW6L9yiohEcsuk +/siON1/5/4DMmidM8LnjW9R45HLGWWGHpX7oyco2iJ+Jy/6Tq+T1MX3PbQKBgQCm +hdsbQJ0u3CrBSmFQ/E9SOlRt0r4+45pVuCOY6yweF2QF9HcXTtbhWQJHLclDHJ5C +Ha18aKuKFN3XzKFFBPKe1jOSBDGlQ/dQGnKx5fr8wMdObM3oiaTlIJuWbRmEUgJT +QARjDIi8Z2b0YUhZx+Q9oSXoe3PyVYehJrQX+/BavQKBgQCIr7Zp0rQPbfqcTL+M +OYHUoNcb14f9f8hXeXHQOqVpsGwxGdRQAU9wbx/4+obKB5xIkzBsVNcJwavisNja +hegnGjTB/9Hc4m+5bMGwH0bhS2eQO4o+YYM2ypDmFQqDLRfFUlZ5PVHffm/aA9+g +GanNBCsmtoHtV6CJ1UZ7NmBuIA== +-----END PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_engine_SUITE_data/rsa_private_key_pwd.pem b/lib/ssh/test/ssh_engine_SUITE_data/rsa_private_key_pwd.pem new file mode 100644 index 0000000000..501662fc35 --- /dev/null +++ b/lib/ssh/test/ssh_engine_SUITE_data/rsa_private_key_pwd.pem @@ -0,0 +1,30 @@ +-----BEGIN ENCRYPTED PRIVATE KEY----- +MIIFDjBABgkqhkiG9w0BBQ0wMzAbBgkqhkiG9w0BBQwwDgQIh888Iq6gxuMCAggA +MBQGCCqGSIb3DQMHBAic/11YZ8Nt5gSCBMjG/Jb4qiMoBS50iQvHXqcETPE+0NBr +jhsn9w94LkdRBstMPAsoKmY98Er96Rnde/NfmqlU9CupKTkd7Ce5poBf72Y6KMED +cPURyjbGRFsu6x9skXB2obhyKYEqAEF2oQAg4Qbe5v1qXBIgDuC/NgiJnM+w2zCZ +LkHSZB2/NmcnvDzcgPF7TM8pTO23xCJ33m37qjfWvHsgocVqZmL9wQ4+wr/NMYjJ +pJvX1OHW1vBsZsXh40WchalYRSB1VeO368QfsE8coRJztqbMzdce9EQdMB6Q6jlO +cetd3moLIoMP4I7HW0/SgokbycTbRiYSvRyU1TGc2WbW6BrFZV24IckcnnVUFatf +6HKUcaYLG68dJcRgs5QMGkcmgVvlddENHFmHZlo0eym/xSiUl/AT8/5odscm6ML8 +wW5sneax+TF4J2eYmiN7yjAUCodXVTNYNDVKo6uUhntlymbM0o4UitVIbPIfTDHl +sxJAEZ7vpuPqeNMxUk6G6zipuEjqsVbnuFSBSZmgKiGYcifRPUmqqINa3DdS4WVx +xaPWdHbHVRD//ze3h/FsA+1lIE5q2kUE0xXseJA1ISog++kJp14XeaaL2j/tx3Ob +OsbcaOAD/IUw/ItDt9kn0qzfnar7sS0Wov8AmJQxHmH7Lm93jHTLM05yE0AR/eBr +Mig2ZdC+9OqVC+GPuBkRjSs8NpltQIDroz6EV9IMwPwXm0szSYoyoPLmlHJUdnLs +ZUef+au6hYkEJBrvuisagnq5eT/fCV3hsjD7yODebNU2CmBTo6X2PRx/xsBHRMWl +QkoM9PBdSCnKv6HpHl4pchuoqU2NpFjN0BCaad6aHfZSTnqgzK4bEh1oO6dI8/rB +/eh71JyFFG5J4xbpaqz5Su01V1iwU5leK5bDwqals4M4+ZGHGciou7qnXUmX2fJl +r6DlMUa/xy+A2ZG0NuZR05yk2oB3+KVNMgp6zFty3XaxwoNtc8GTLtLnBnIh2rlP +mE1+I65LRWwrNQalPeOAUrYuEzhyp2Df7a8Ykas5PUH7MGR/S0Ge/dLxtE2bJuK4 +znbLAsGhvo/SbNxYqIp6D4iDtd3va6yUGncy41paA/vTKFVvXZDrXcwJQYYCVOGT +OwdzNuozU8Dc7oxsd8oakfC46kvmVaOrGvZbm56PFfprcaL/Hslska5xxEni/eZe +WRxZbCBhAVqS1pn5zkDQVUe9uFlR/x39Qi01HIlKLBsjpSs6qQsFArMe8hgXmXLG +xP+dyVuOE18NzSewdEjeqSRKIM7Qi8EOjZsI4HdSRBY7bh9VhmaVXDZiCSf33TTE +3y8nimzQAeuGoYg6WqHmWWC2Qnpki2HlaIH/ayXEyQWkP/qvg61e8ovdg9Fy8JOO +0AacXVt5zj0q00AW5bKx7usi4NIjZedi86hUm6H19aBm7r86BKjwYTEI/GOcdrbV +9HC/8ayOimgwiAG3gq+aLioWym+Z6KnsbVd7XReVbvM/InQx54WA2y5im0A+/c67 +oQFFPV84XGX9waeqv/K4Wzkm6HW+qVAEM67482VGOf0PVrlQMno6dOotT/Y7ljoZ +2iz0LmN9yylJnLPDrr1i6gzbs5OhhUgbF5LI2YP2wWdCZTl/DrKSIvQZWl8U+tw3 +ciA= +-----END ENCRYPTED PRIVATE KEY----- diff --git a/lib/ssh/test/ssh_key_cb_engine_keys.erl b/lib/ssh/test/ssh_key_cb_engine_keys.erl new file mode 100644 index 0000000000..fc9cbfd49b --- /dev/null +++ b/lib/ssh/test/ssh_key_cb_engine_keys.erl @@ -0,0 +1,62 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2015-2017. 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% +%% + +%% +%%---------------------------------------------------------------------- + +%% Note: This module is used by ssh_basic_SUITE + +-module(ssh_key_cb_engine_keys). +-behaviour(ssh_server_key_api). +-compile(export_all). + +host_key(SshAlg, Options) -> + KBopts = proplists:get_value(key_cb_private, Options, []), + Engine = proplists:get_value(engine, KBopts), + case proplists:get_value(SshAlg, KBopts) of + undefined -> + {error, {unknown_alg,SshAlg}}; + KeyId -> + case crypto_alg(SshAlg) of + undefined -> + {error, {unsupported_alg,SshAlg}}; + CryptoAlg -> + PrivKey = #{engine => Engine, + key_id => KeyId, + algorithm => CryptoAlg}, + %% Is there a key with this reference ? + case crypto:privkey_to_pubkey(CryptoAlg, PrivKey) of + [_|_] -> + {ok, PrivKey}; + _ -> + {error, {no_hostkey,SshAlg}} + end + end + end. + +is_auth_key(_PublicUserKey, _User, _Options) -> + false. + + + +crypto_alg('ssh-rsa') -> rsa; +crypto_alg('ssh-dss') -> dss; +crypto_alg(_) -> undefined. + diff --git a/lib/ssh/test/ssh_options_SUITE.erl b/lib/ssh/test/ssh_options_SUITE.erl index 8b454ffe5d..144ec7f8fd 100644 --- a/lib/ssh/test/ssh_options_SUITE.erl +++ b/lib/ssh/test/ssh_options_SUITE.erl @@ -36,7 +36,9 @@ id_string_no_opt_client/1, id_string_no_opt_server/1, id_string_own_string_client/1, + id_string_own_string_client_trail_space/1, id_string_own_string_server/1, + id_string_own_string_server_trail_space/1, id_string_random_client/1, id_string_random_server/1, max_sessions_sftp_start_channel_parallel/1, @@ -116,9 +118,11 @@ all() -> hostkey_fingerprint_check_list, id_string_no_opt_client, id_string_own_string_client, + id_string_own_string_client_trail_space, id_string_random_client, id_string_no_opt_server, id_string_own_string_server, + id_string_own_string_server_trail_space, id_string_random_server, {group, hardening_tests} ]. @@ -1035,6 +1039,19 @@ id_string_own_string_client(Config) -> end. %%-------------------------------------------------------------------- +id_string_own_string_client_trail_space(Config) -> + {Server, _Host, Port} = fake_daemon(Config), + {error,_} = ssh:connect("localhost", Port, [{id_string,"Pelle "}], 1000), + receive + {id,Server,"SSH-2.0-Pelle \r\n"} -> + ok; + {id,Server,Other} -> + ct:fail("Unexpected id: ~s.",[Other]) + after 5000 -> + {fail,timeout} + end. + +%%-------------------------------------------------------------------- id_string_random_client(Config) -> {Server, _Host, Port} = fake_daemon(Config), {error,_} = ssh:connect("localhost", Port, [{id_string,random}], 1000), @@ -1063,6 +1080,12 @@ id_string_own_string_server(Config) -> {ok,"SSH-2.0-Olle\r\n"} = gen_tcp:recv(S1, 0, 2000). %%-------------------------------------------------------------------- +id_string_own_string_server_trail_space(Config) -> + {_Server, Host, Port} = ssh_test_lib:std_daemon(Config, [{id_string,"Olle "}]), + {ok,S1}=ssh_test_lib:gen_tcp_connect(Host,Port,[{active,false},{packet,line}]), + {ok,"SSH-2.0-Olle \r\n"} = gen_tcp:recv(S1, 0, 2000). + +%%-------------------------------------------------------------------- id_string_random_server(Config) -> {_Server, Host, Port} = ssh_test_lib:std_daemon(Config, [{id_string,random}]), {ok,S1}=ssh_test_lib:gen_tcp_connect(Host,Port,[{active,false},{packet,line}]), diff --git a/lib/ssh/test/ssh_protocol_SUITE.erl b/lib/ssh/test/ssh_protocol_SUITE.erl index 74f802cf57..3e3e151781 100644 --- a/lib/ssh/test/ssh_protocol_SUITE.erl +++ b/lib/ssh/test/ssh_protocol_SUITE.erl @@ -630,11 +630,12 @@ client_handles_keyboard_interactive_0_pwds(Config) -> %%%-------------------------------------------------------------------- -client_info_line(_Config) -> +client_info_line(Config) -> %% A client must not send an info-line. If it does, the server should handle %% handle this gracefully {ok,Pid} = ssh_eqc_event_handler:add_report_handler(), - {_, _, Port} = ssh_test_lib:daemon([]), + DataDir = proplists:get_value(data_dir, Config), + {_, _, Port} = ssh_test_lib:daemon([{system_dir,DataDir}]), %% Fake client: {ok,S} = gen_tcp:connect("localhost",Port,[]), diff --git a/lib/ssh/test/ssh_sftp_SUITE.erl b/lib/ssh/test/ssh_sftp_SUITE.erl index 7aa3d8a00a..c2f9c0eba8 100644 --- a/lib/ssh/test/ssh_sftp_SUITE.erl +++ b/lib/ssh/test/ssh_sftp_SUITE.erl @@ -181,8 +181,9 @@ init_per_group(openssh_server, Config) -> [{peer, {fmt_host(IPx),Portx}}, {group, openssh_server} | Config]; {error,"Key exchange failed"} -> {skip, "openssh server doesn't support the tested kex algorithm"}; - _ -> - {skip, "No openssh server"} + Other -> + ct:log("No openssh server. Cause:~n~p~n",[Other]), + {skip, "No openssh daemon (see log in testcase)"} end; init_per_group(remote_tar, Config) -> diff --git a/lib/ssh/test/ssh_sftpd_SUITE.erl b/lib/ssh/test/ssh_sftpd_SUITE.erl index 763649a12f..5fc948fbed 100644 --- a/lib/ssh/test/ssh_sftpd_SUITE.erl +++ b/lib/ssh/test/ssh_sftpd_SUITE.erl @@ -34,7 +34,7 @@ -define(PASSWD, "Sesame"). -define(XFER_PACKET_SIZE, 32768). -define(XFER_WINDOW_SIZE, 4*?XFER_PACKET_SIZE). --define(TIMEOUT, 10000). +-define(SSH_TIMEOUT, 10000). -define(REG_ATTERS, <<0,0,0,0,1>>). -define(UNIX_EPOCH, 62167219200). @@ -161,9 +161,9 @@ init_per_testcase(TestCase, Config) -> {silently_accept_hosts, true}]), {ok, Channel} = ssh_connection:session_channel(Cm, ?XFER_WINDOW_SIZE, - ?XFER_PACKET_SIZE, ?TIMEOUT), + ?XFER_PACKET_SIZE, ?SSH_TIMEOUT), - success = ssh_connection:subsystem(Cm, Channel, "sftp", ?TIMEOUT), + success = ssh_connection:subsystem(Cm, Channel, "sftp", ?SSH_TIMEOUT), ProtocolVer = case atom_to_list(TestCase) of "ver3_" ++ _ -> diff --git a/lib/ssh/test/ssh_test_lib.erl b/lib/ssh/test/ssh_test_lib.erl index 83819b97a5..f97c3b1352 100644 --- a/lib/ssh/test/ssh_test_lib.erl +++ b/lib/ssh/test/ssh_test_lib.erl @@ -28,9 +28,7 @@ -include_lib("public_key/include/public_key.hrl"). -include_lib("common_test/include/ct.hrl"). -include_lib("ssh/src/ssh_transport.hrl"). - - --define(TIMEOUT, 50000). +-include("ssh_test_lib.hrl"). %%%---------------------------------------------------------------- connect(Port, Options) when is_integer(Port) -> @@ -55,7 +53,7 @@ daemon(Host, Options) -> daemon(Host, Port, Options) -> - ct:log("~p:~p Calling ssh:daemon(~p, ~p, ~p)",[?MODULE,?LINE,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} -> {ok,L} = ssh:daemon_info(Pid), @@ -201,15 +199,17 @@ init_io_server(TestCase) -> loop_io_server(TestCase, Buff0) -> receive - {input, TestCase, Line} -> + {input, TestCase, Line} = _INP -> + %%ct:log("io_server ~p:~p ~p got ~p",[?MODULE,?LINE,self(),_INP]), loop_io_server(TestCase, Buff0 ++ [Line]); - {io_request, From, ReplyAs, Request} -> + {io_request, From, ReplyAs, Request} = _REQ-> + %%ct:log("io_server ~p:~p ~p got ~p",[?MODULE,?LINE,self(),_REQ]), {ok, Reply, Buff} = io_request(Request, TestCase, From, ReplyAs, Buff0), io_reply(From, ReplyAs, Reply), loop_io_server(TestCase, Buff); {'EXIT',_, _} = _Exit -> -%% ct:log("ssh_test_lib:loop_io_server/2 got ~p",[_Exit]), + ct:log("ssh_test_lib:loop_io_server/2 got ~p",[_Exit]), ok after 30000 -> ct:fail("timeout ~p:~p",[?MODULE,?LINE]) @@ -600,6 +600,7 @@ check_ssh_client_support2(P) -> {P, {data, _A}} -> check_ssh_client_support2(P); {P, {exit_status, E}} -> + ct:log("~p:~p exit_status:~n~p",[?MODULE,?LINE,E]), E after 5000 -> ct:log("Openssh command timed out ~n"), @@ -651,14 +652,14 @@ default_algorithms(sshc, DaemonOptions) -> {hostport,Srvr,{_Host,Port}} -> spawn(fun()-> os:cmd(lists:concat(["ssh -o \"StrictHostKeyChecking no\" -p ",Port," localhost"])) end) after ?TIMEOUT -> - ct:fail("No server respons 1") + ct:fail("No server respons (timeout) 1") end, receive {result,Srvr,L} -> L after ?TIMEOUT -> - ct:fail("No server respons 2") + ct:fail("No server respons (timeout) 2") end. run_fake_ssh({ok,InitialState}) -> @@ -772,12 +773,12 @@ ssh_type1() -> not_found; Path -> ct:log("~p:~p Found \"ssh\" at ~p",[?MODULE,?LINE,Path]), - case os:cmd("ssh -V") of + case installed_ssh_version(timeout) of Version = "OpenSSH" ++ _ -> ct:log("~p:~p Found OpenSSH ~p",[?MODULE,?LINE,Version]), openSSH; - Str -> - ct:log("ssh client ~p is unknown",[Str]), + Other -> + ct:log("ssh client ~p is unknown",[Other]), unknown end end @@ -787,6 +788,20 @@ ssh_type1() -> not_found end. +installed_ssh_version(TimeoutReturn) -> + Parent = self(), + Pid = spawn(fun() -> + Parent ! {open_ssh_version, os:cmd("ssh -V")} + end), + receive + {open_ssh_version, V} -> + V + after ?TIMEOUT -> + exit(Pid, kill), + TimeoutReturn + end. + + algo_intersection([], _) -> []; diff --git a/lib/ssh/test/ssh_test_lib.hrl b/lib/ssh/test/ssh_test_lib.hrl index 54c93b7e87..eaf856e6e8 100644 --- a/lib/ssh/test/ssh_test_lib.hrl +++ b/lib/ssh/test/ssh_test_lib.hrl @@ -1,4 +1,9 @@ %%------------------------------------------------------------------------- +%% Timeout time in ms +%%------------------------------------------------------------------------- +-define(TIMEOUT, 27000). + +%%------------------------------------------------------------------------- %% Check for usable crypt %%------------------------------------------------------------------------- -define(CHECK_CRYPTO(Available), diff --git a/lib/ssh/test/ssh_to_openssh_SUITE.erl b/lib/ssh/test/ssh_to_openssh_SUITE.erl index 75d5b5e296..9df404d7ed 100644 --- a/lib/ssh/test/ssh_to_openssh_SUITE.erl +++ b/lib/ssh/test/ssh_to_openssh_SUITE.erl @@ -27,7 +27,6 @@ %% Note: This directive should only be used in test suites. -compile(export_all). --define(TIMEOUT, 50000). -define(SSH_DEFAULT_PORT, 22). -define(REKEY_DATA_TMO, 65000). @@ -49,19 +48,9 @@ all() -> end. groups() -> - [{erlang_client, [], [erlang_shell_client_openssh_server, - erlang_client_openssh_server_exec_compressed, - erlang_client_openssh_server_setenv, - 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_client_openssh_server_renegotiate + [{erlang_client, [], [erlang_shell_client_openssh_server ]}, - {erlang_server, [], [erlang_server_openssh_client_public_key_dsa, - erlang_server_openssh_client_public_key_rsa, - erlang_server_openssh_client_renegotiate + {erlang_server, [], [erlang_server_openssh_client_renegotiate ]} ]. @@ -69,7 +58,7 @@ init_per_suite(Config) -> ?CHECK_CRYPTO( case gen_tcp:connect("localhost", 22, []) of {error,econnrefused} -> - {skip,"No openssh deamon"}; + {skip,"No openssh deamon (econnrefused)"}; _ -> ssh_test_lib:openssh_sanity_check(Config) end @@ -101,15 +90,6 @@ end_per_group(_, Config) -> 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(erlang_client_openssh_server_publickey_rsa, Config) -> - chk_key(sshd, 'ssh-rsa', ".ssh/id_rsa", Config); - init_per_testcase(erlang_server_openssh_client_renegotiate, Config) -> case os:type() of {unix,_} -> ssh:start(), Config; @@ -123,27 +103,6 @@ end_per_testcase(_TestCase, _Config) -> ssh:stop(), ok. - -chk_key(Pgm, Name, File, Config) -> - case ssh_test_lib:openssh_supports(Pgm, public_key, Name) of - false -> - {skip,lists:concat(["openssh client does not support ",Name])}; - true -> - {ok,[[Home]]} = init:get_argument(home), - KeyFile = filename:join(Home, File), - case file:read_file(KeyFile) of - {ok, Pem} -> - case public_key:pem_decode(Pem) of - [{_,_, not_encrypted}] -> - init_per_testcase('__default__',Config); - _ -> - {skip, {error, "Has pass phrase can not be used by automated test case"}} - end; - _ -> - {skip, lists:concat(["no ~/",File])} - end - end. - %%-------------------------------------------------------------------- %% Test Cases -------------------------------------------------------- %%-------------------------------------------------------------------- @@ -161,219 +120,6 @@ erlang_shell_client_openssh_server(Config) when is_list(Config) -> receive_logout(), receive_normal_exit(Shell). -%-------------------------------------------------------------------- -erlang_client_openssh_server_exec() -> - [{doc, "Test api function ssh_connection:exec"}]. - -erlang_client_openssh_server_exec(Config) when is_list(Config) -> - ConnectionRef = ssh_test_lib:connect(?SSH_DEFAULT_PORT, [{silently_accept_hosts, true}, - {user_interaction, false}]), - {ok, ChannelId0} = ssh_connection:session_channel(ConnectionRef, infinity), - success = ssh_connection:exec(ConnectionRef, ChannelId0, - "echo testing", infinity), - Data0 = {ssh_cm, ConnectionRef, {data, ChannelId0, 0, <<"testing\n">>}}, - case ssh_test_lib:receive_exec_result(Data0) of - expected -> - ssh_test_lib:receive_exec_end(ConnectionRef, ChannelId0); - {unexpected_msg,{ssh_cm, ConnectionRef, {exit_status, ChannelId0, 0}} - = ExitStatus0} -> - ct:log("0: Collected data ~p", [ExitStatus0]), - ssh_test_lib:receive_exec_result(Data0, - ConnectionRef, ChannelId0); - Other0 -> - ct:fail(Other0) - end, - - {ok, ChannelId1} = ssh_connection:session_channel(ConnectionRef, infinity), - success = ssh_connection:exec(ConnectionRef, ChannelId1, - "echo testing1", infinity), - Data1 = {ssh_cm, ConnectionRef, {data, ChannelId1, 0, <<"testing1\n">>}}, - case ssh_test_lib:receive_exec_result(Data1) of - expected -> - ssh_test_lib:receive_exec_end(ConnectionRef, ChannelId1); - {unexpected_msg,{ssh_cm, ConnectionRef, {exit_status, ChannelId1, 0}} - = ExitStatus1} -> - ct:log("0: Collected data ~p", [ExitStatus1]), - ssh_test_lib:receive_exec_result(Data1, - ConnectionRef, ChannelId1); - Other1 -> - ct:fail(Other1) - end. - -%%-------------------------------------------------------------------- -erlang_client_openssh_server_exec_compressed() -> - [{doc, "Test that compression option works"}]. - -erlang_client_openssh_server_exec_compressed(Config) when is_list(Config) -> - CompressAlgs = [zlib, '[email protected]',none], - case ssh_test_lib:ssh_supports(CompressAlgs, compression) of - {false,L} -> - {skip, io_lib:format("~p compression is not supported",[L])}; - - true -> - ConnectionRef = ssh_test_lib:connect(?SSH_DEFAULT_PORT, [{silently_accept_hosts, true}, - {user_interaction, false}, - {preferred_algorithms, - [{compression,CompressAlgs}]}]), - {ok, ChannelId} = ssh_connection:session_channel(ConnectionRef, infinity), - success = ssh_connection:exec(ConnectionRef, ChannelId, - "echo testing", infinity), - Data = {ssh_cm, ConnectionRef, {data, ChannelId, 0, <<"testing\n">>}}, - case ssh_test_lib:receive_exec_result(Data) of - expected -> - ssh_test_lib:receive_exec_end(ConnectionRef, ChannelId); - {unexpected_msg,{ssh_cm, ConnectionRef, - {exit_status, ChannelId, 0}} = ExitStatus} -> - ct:log("0: Collected data ~p", [ExitStatus]), - ssh_test_lib:receive_exec_result(Data, ConnectionRef, ChannelId); - Other -> - ct:fail(Other) - end - end. - -%%-------------------------------------------------------------------- -erlang_client_openssh_server_kexs() -> - [{doc, "Test that we can connect with different KEXs."}]. - -erlang_client_openssh_server_kexs(Config) when is_list(Config) -> - KexAlgos = try proplists:get_value(kex, proplists:get_value(common_algs,Config)) - catch _:_ -> [] - end, - comment(KexAlgos), - case KexAlgos of - [] -> {skip, "No common kex algorithms"}; - _ -> - Success = - lists:foldl( - fun(Kex, Acc) -> - ConnectionRef = - ssh_test_lib:connect(?SSH_DEFAULT_PORT, [{silently_accept_hosts, true}, - {user_interaction, false}, - {preferred_algorithms, - [{kex,[Kex]}]}]), - - {ok, ChannelId} = - ssh_connection:session_channel(ConnectionRef, infinity), - success = - ssh_connection:exec(ConnectionRef, ChannelId, - "echo testing", infinity), - - ExpectedData = {ssh_cm, ConnectionRef, {data, ChannelId, 0, <<"testing\n">>}}, - case ssh_test_lib:receive_exec_result(ExpectedData) of - expected -> - ssh_test_lib:receive_exec_end(ConnectionRef, ChannelId), - Acc; - {unexpected_msg,{ssh_cm, ConnectionRef, - {exit_status, ChannelId, 0}} = ExitStatus} -> - ct:log("0: Collected data ~p", [ExitStatus]), - ssh_test_lib:receive_exec_result(ExpectedData, ConnectionRef, ChannelId), - Acc; - Other -> - ct:log("~p failed: ~p",[Kex,Other]), - false - end - end, true, KexAlgos), - case Success of - true -> - ok; - false -> - {fail, "Kex failed for one or more algos"} - end - end. - -%%-------------------------------------------------------------------- -erlang_client_openssh_server_setenv() -> - [{doc, "Test api function ssh_connection:setenv"}]. - -erlang_client_openssh_server_setenv(Config) when is_list(Config) -> - ConnectionRef = - ssh_test_lib:connect(?SSH_DEFAULT_PORT, [{silently_accept_hosts, true}, - {user_interaction, false}]), - {ok, ChannelId} = - ssh_connection:session_channel(ConnectionRef, infinity), - Env = case ssh_connection:setenv(ConnectionRef, ChannelId, - "ENV_TEST", "testing_setenv", - infinity) of - success -> - <<"tesing_setenv\n">>; - failure -> - <<"\n">> - end, - success = ssh_connection:exec(ConnectionRef, ChannelId, - "echo $ENV_TEST", infinity), - Data = {ssh_cm, ConnectionRef, {data, ChannelId, 0, Env}}, - case ssh_test_lib:receive_exec_result(Data) of - expected -> - ssh_test_lib:receive_exec_end(ConnectionRef, ChannelId); - {unexpected_msg,{ssh_cm, ConnectionRef, - {data,0,1, UnxpectedData}}} -> - %% Some os may return things as - %% ENV_TEST: Undefined variable.\n" - ct:log("UnxpectedData: ~p", [UnxpectedData]), - ssh_test_lib:receive_exec_end(ConnectionRef, ChannelId); - {unexpected_msg,{ssh_cm, ConnectionRef, {exit_status, ChannelId, 0}} - = ExitStatus} -> - ct:log("0: Collected data ~p", [ExitStatus]), - ssh_test_lib:receive_exec_result(Data, - ConnectionRef, ChannelId); - Other -> - ct:fail(Other) - end. - -%%-------------------------------------------------------------------- - -%% setenv not meaningfull on erlang ssh daemon! - -%%-------------------------------------------------------------------- -erlang_client_openssh_server_publickey_rsa(Config) -> - erlang_client_openssh_server_publickey_X(Config, 'ssh-rsa'). - -erlang_client_openssh_server_publickey_dsa(Config) -> - erlang_client_openssh_server_publickey_X(Config, 'ssh-dss'). - - -erlang_client_openssh_server_publickey_X(_Config, Alg) -> - ConnectionRef = - ssh_test_lib:connect(?SSH_DEFAULT_PORT, - [{pref_public_key_algs, [Alg]}, - {user_interaction, false}, - {auth_methods, "publickey"}, - silently_accept_hosts]), - {ok, Channel} = - ssh_connection:session_channel(ConnectionRef, infinity), - ok = ssh_connection:close(ConnectionRef, Channel), - ok = ssh:close(ConnectionRef). - -%%-------------------------------------------------------------------- -erlang_server_openssh_client_public_key_dsa() -> - [{timetrap, {seconds,(?TIMEOUT div 1000)+10}}]. -erlang_server_openssh_client_public_key_dsa(Config) when is_list(Config) -> - erlang_server_openssh_client_public_key_X(Config, 'ssh-dss'). - -erlang_server_openssh_client_public_key_rsa() -> - [{timetrap, {seconds,(?TIMEOUT div 1000)+10}}]. -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, Alg) -> - SystemDir = proplists:get_value(data_dir, Config), - PrivDir = proplists:get_value(priv_dir, Config), - KnownHosts = filename:join(PrivDir, "known_hosts"), - {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, - {preferred_algorithms,[{public_key, [Alg]}]}, - {auth_methods, "publickey"}, - {failfun, fun ssh_test_lib:failfun/2}]), - ct:sleep(500), - - Cmd = ssh_test_lib:open_sshc_cmd(Host, Port, - [" -o UserKnownHostsFile=", KnownHosts, - " -o StrictHostKeyChecking=no"], - "1+1."), - OpenSsh = ssh_test_lib:open_port({spawn, Cmd}), - ssh_test_lib:rcv_expected({data,<<"2\n">>}, OpenSsh, ?TIMEOUT), - ssh:stop_daemon(Pid). - %%-------------------------------------------------------------------- %% Test that the Erlang/OTP server can renegotiate with openSSH erlang_server_openssh_client_renegotiate(Config) -> @@ -431,108 +177,6 @@ erlang_server_openssh_client_renegotiate(Config) -> end. %%-------------------------------------------------------------------- -erlang_client_openssh_server_renegotiate(_Config) -> - process_flag(trap_exit, true), - IO = ssh_test_lib:start_io_server(), - Ref = make_ref(), - Parent = self(), - - Shell = - spawn_link( - fun() -> - Host = ssh_test_lib:hostname(), - Options = [{user_interaction, false}, - {silently_accept_hosts,true}], - group_leader(IO, self()), - {ok, ConnRef} = ssh:connect(Host, ?SSH_DEFAULT_PORT, Options), - ct:log("Parent = ~p, IO = ~p, Shell = ~p, ConnRef = ~p~n",[Parent, IO, self(), ConnRef]), - case ssh_connection:session_channel(ConnRef, infinity) of - {ok,ChannelId} -> - success = ssh_connection:ptty_alloc(ConnRef, ChannelId, []), - Args = [{channel_cb, ssh_shell}, - {init_args,[ConnRef, ChannelId]}, - {cm, ConnRef}, {channel_id, ChannelId}], - {ok, State} = ssh_channel:init([Args]), - Parent ! {ok, Ref, ConnRef}, - ssh_channel:enter_loop(State); - Error -> - Parent ! {error, Ref, Error} - end, - receive - nothing -> ok - end - end), - - receive - {error, Ref, Error} -> - ct:fail("Error=~p",[Error]); - {ok, Ref, ConnectionRef} -> - IO ! {input, self(), "echo Hej1\n"}, - receive_data("Hej1", ConnectionRef), - Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), - ssh_connection_handler:renegotiate(ConnectionRef), - IO ! {input, self(), "echo Hej2\n"}, - receive_data("Hej2", ConnectionRef), - Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), - IO ! {input, self(), "exit\n"}, - receive_logout(), - receive_normal_exit(Shell), - true = (Kex1 =/= Kex2) - end. - -%%-------------------------------------------------------------------- -erlang_client_openssh_server_password() -> - [{doc, "Test client password option"}]. -erlang_client_openssh_server_password(Config) when is_list(Config) -> - %% to make sure we don't public-key-auth - UserDir = proplists:get_value(data_dir, Config), - {error, Reason0} = - ssh:connect(any, ?SSH_DEFAULT_PORT, [{silently_accept_hosts, true}, - {user, "foo"}, - {password, "morot"}, - {user_interaction, false}, - {user_dir, UserDir}]), - - ct:log("Test of user foo that does not exist. " - "Error msg: ~p~n", [Reason0]), - - User = string:strip(os:cmd("whoami"), right, $\n), - - case length(string:tokens(User, " ")) of - 1 -> - {error, Reason1} = - ssh:connect(any, ?SSH_DEFAULT_PORT, - [{silently_accept_hosts, true}, - {user, User}, - {password, "foo"}, - {user_interaction, false}, - {user_dir, UserDir}]), - ct:log("Test of wrong Pasword. " - "Error msg: ~p~n", [Reason1]); - _ -> - ct:log("Whoami failed reason: ~n", []) - end. - -%%-------------------------------------------------------------------- - -erlang_client_openssh_server_nonexistent_subsystem() -> - [{doc, "Test client password option"}]. -erlang_client_openssh_server_nonexistent_subsystem(Config) when is_list(Config) -> - - ConnectionRef = ssh_test_lib:connect(?SSH_DEFAULT_PORT, - [{user_interaction, false}, - silently_accept_hosts]), - - {ok, ChannelId} = ssh_connection:session_channel(ConnectionRef, infinity), - - failure = ssh_connection:subsystem(ConnectionRef, ChannelId, "foo", infinity). - -%%-------------------------------------------------------------------- -% -%% Not possible to send password with openssh without user interaction -%% -%%-------------------------------------------------------------------- -%%-------------------------------------------------------------------- %%% Internal functions ----------------------------------------------- %%-------------------------------------------------------------------- receive_data(Data, Conn) -> diff --git a/lib/ssh/vsn.mk b/lib/ssh/vsn.mk index 5154658e8a..004db6e3a2 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.6.1 +SSH_VSN = 4.6.4 APP_VSN = "ssh-$(SSH_VSN)" diff --git a/lib/ssl/doc/src/Makefile b/lib/ssl/doc/src/Makefile index d54ef47461..f9128e8e45 100644 --- a/lib/ssl/doc/src/Makefile +++ b/lib/ssl/doc/src/Makefile @@ -43,9 +43,9 @@ XML_REF6_FILES = ssl_app.xml XML_PART_FILES = usersguide.xml XML_CHAPTER_FILES = \ + ssl_introduction.xml \ ssl_protocol.xml \ using_ssl.xml \ - pkix_certs.xml \ ssl_distribution.xml \ notes.xml diff --git a/lib/ssl/doc/src/notes.xml b/lib/ssl/doc/src/notes.xml index 4c6a204e63..79176f5edf 100644 --- a/lib/ssl/doc/src/notes.xml +++ b/lib/ssl/doc/src/notes.xml @@ -27,6 +27,136 @@ </header> <p>This document describes the changes made to the SSL application.</p> +<section><title>SSL 8.2.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Packet options cannot be supported for unreliable + transports, that is, packet option for DTLS over udp will + not be supported.</p> + <p> + Own Id: OTP-14664</p> + </item> + <item> + <p> + Ensure data delivery before close if possible. This fix + is related to fix in PR-1479.</p> + <p> + Own Id: OTP-14794</p> + </item> + </list> + </section> + + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + The crypto API is extended to use private/public keys + stored in an Engine for sign/verify or encrypt/decrypt + operations.</p> + <p> + The ssl application provides an API to use this new + engine concept in TLS.</p> + <p> + Own Id: OTP-14448</p> + </item> + <item> + <p> + Implemented renegotiation for DTLS</p> + <p> + Own Id: OTP-14563</p> + </item> + <item> + <p> + A new command line option <c>-ssl_dist_optfile</c> has + been added to facilitate specifying the many options + needed when using SSL as the distribution protocol.</p> + <p> + Own Id: OTP-14657</p> + </item> + </list> + </section> + +</section> + +<section><title>SSL 8.2.2</title> + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + TLS sessions must be registered with SNI if provided, so + that sessions where client hostname verification would + fail can not connect reusing a session created when the + server name verification succeeded.</p> + <p> + Own Id: OTP-14632</p> + </item> + <item> + <p> An erlang TLS server configured with cipher suites + using rsa key exchange, may be vulnerable to an Adaptive + Chosen Ciphertext attack (AKA Bleichenbacher attack) + against RSA, which when exploited, may result in + plaintext recovery of encrypted messages and/or a + Man-in-the-middle (MiTM) attack, despite the attacker not + having gained access to the server’s private key + itself. <url + href="https://nvd.nist.gov/vuln/detail/CVE-2017-1000385">CVE-2017-1000385</url> + </p> <p> Exploiting this vulnerability to perform + plaintext recovery of encrypted messages will, in most + practical cases, allow an attacker to read the plaintext + only after the session has completed. Only TLS sessions + established using RSA key exchange are vulnerable to this + attack. </p> <p> Exploiting this vulnerability to conduct + a MiTM attack requires the attacker to complete the + initial attack, which may require thousands of server + requests, during the handshake phase of the targeted + session within the window of the configured handshake + timeout. This attack may be conducted against any TLS + session using RSA signatures, but only if cipher suites + using RSA key exchange are also enabled on the server. + The limited window of opportunity, limitations in + bandwidth, and latency make this attack significantly + more difficult to execute. </p> <p> RSA key exchange is + enabled by default although least prioritized if server + order is honored. For such a cipher suite to be chosen it + must also be supported by the client and probably the + only shared cipher suite. </p> <p> Captured TLS sessions + encrypted with ephemeral cipher suites (DHE or ECDHE) are + not at risk for subsequent decryption due to this + vulnerability. </p> <p> As a workaround if default cipher + suite configuration was used you can configure the server + to not use vulnerable suites with the ciphers option like + this: </p> <c> {ciphers, [Suite || Suite <- + ssl:cipher_suites(), element(1,Suite) =/= rsa]} </c> <p> + that is your code will look somethingh like this: </p> + <c> ssl:listen(Port, [{ciphers, [Suite || Suite <- + ssl:cipher_suites(), element(1,S) =/= rsa]} | Options]). + </c> <p> Thanks to Hanno Böck, Juraj Somorovsky and + Craig Young for reporting this vulnerability. </p> + <p> + Own Id: OTP-14748</p> + </item> + </list> + </section> + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + If no SNI is available and the hostname is an IP-address + also check for IP-address match. This check is not as + good as a DNS hostname check and certificates using + IP-address are not recommended.</p> + <p> + Own Id: OTP-14655</p> + </item> + </list> + </section> + +</section> <section><title>SSL 8.2.1</title> @@ -175,9 +305,59 @@ </item> </list> </section> - </section> +<section><title>SSL 8.1.3.1</title> + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> An erlang TLS server configured with cipher suites + using rsa key exchange, may be vulnerable to an Adaptive + Chosen Ciphertext attack (AKA Bleichenbacher attack) + against RSA, which when exploited, may result in + plaintext recovery of encrypted messages and/or a + Man-in-the-middle (MiTM) attack, despite the attacker not + having gained access to the server’s private key + itself. <url + href="https://nvd.nist.gov/vuln/detail/CVE-2017-1000385">CVE-2017-1000385</url> + </p> <p> Exploiting this vulnerability to perform + plaintext recovery of encrypted messages will, in most + practical cases, allow an attacker to read the plaintext + only after the session has completed. Only TLS sessions + established using RSA key exchange are vulnerable to this + attack. </p> <p> Exploiting this vulnerability to conduct + a MiTM attack requires the attacker to complete the + initial attack, which may require thousands of server + requests, during the handshake phase of the targeted + session within the window of the configured handshake + timeout. This attack may be conducted against any TLS + session using RSA signatures, but only if cipher suites + using RSA key exchange are also enabled on the server. + The limited window of opportunity, limitations in + bandwidth, and latency make this attack significantly + more difficult to execute. </p> <p> RSA key exchange is + enabled by default although least prioritized if server + order is honored. For such a cipher suite to be chosen it + must also be supported by the client and probably the + only shared cipher suite. </p> <p> Captured TLS sessions + encrypted with ephemeral cipher suites (DHE or ECDHE) are + not at risk for subsequent decryption due to this + vulnerability. </p> <p> As a workaround if default cipher + suite configuration was used you can configure the server + to not use vulnerable suites with the ciphers option like + this: </p> <c> {ciphers, [Suite || Suite <- + ssl:cipher_suites(), element(1,Suite) =/= rsa]} </c> <p> + that is your code will look somethingh like this: </p> + <c> ssl:listen(Port, [{ciphers, [Suite || Suite <- + ssl:cipher_suites(), element(1,S) =/= rsa]} | Options]). + </c> <p> Thanks to Hanno Böck, Juraj Somorovsky and + Craig Young for reporting this vulnerability. </p> + <p> + Own Id: OTP-14748</p> + </item> + </list> + </section> +</section> <section><title>SSL 8.1.3</title> <section><title>Fixed Bugs and Malfunctions</title> @@ -556,6 +736,60 @@ </section> + <section><title>SSL 7.3.3.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> An erlang TLS server configured with cipher suites + using rsa key exchange, may be vulnerable to an Adaptive + Chosen Ciphertext attack (AKA Bleichenbacher attack) + against RSA, which when exploited, may result in + plaintext recovery of encrypted messages and/or a + Man-in-the-middle (MiTM) attack, despite the attacker not + having gained access to the server’s private key + itself. <url + href="https://nvd.nist.gov/vuln/detail/CVE-2017-1000385">CVE-2017-1000385</url> + </p> <p> Exploiting this vulnerability to perform + plaintext recovery of encrypted messages will, in most + practical cases, allow an attacker to read the plaintext + only after the session has completed. Only TLS sessions + established using RSA key exchange are vulnerable to this + attack. </p> <p> Exploiting this vulnerability to conduct + a MiTM attack requires the attacker to complete the + initial attack, which may require thousands of server + requests, during the handshake phase of the targeted + session within the window of the configured handshake + timeout. This attack may be conducted against any TLS + session using RSA signatures, but only if cipher suites + using RSA key exchange are also enabled on the server. + The limited window of opportunity, limitations in + bandwidth, and latency make this attack significantly + more difficult to execute. </p> <p> RSA key exchange is + enabled by default although least prioritized if server + order is honored. For such a cipher suite to be chosen it + must also be supported by the client and probably the + only shared cipher suite. </p> <p> Captured TLS sessions + encrypted with ephemeral cipher suites (DHE or ECDHE) are + not at risk for subsequent decryption due to this + vulnerability. </p> <p> As a workaround if default cipher + suite configuration was used you can configure the server + to not use vulnerable suites with the ciphers option like + this: </p> <c> {ciphers, [Suite || Suite <- + ssl:cipher_suites(), element(1,Suite) =/= rsa]} </c> <p> + that is your code will look somethingh like this: </p> + <c> ssl:listen(Port, [{ciphers, [Suite || Suite <- + ssl:cipher_suites(), element(1,S) =/= rsa]} | Options]). + </c> <p> Thanks to Hanno Böck, Juraj Somorovsky and + Craig Young for reporting this vulnerability. </p> + <p> + Own Id: OTP-14748</p> + </item> + </list> + </section> + + </section> + <section><title>SSL 7.3.3</title> <section><title>Fixed Bugs and Malfunctions</title> @@ -585,7 +819,59 @@ </list> </section> + <section><title>SSL 7.3.3.0.1</title> + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> An erlang TLS server configured with cipher suites + using rsa key exchange, may be vulnerable to an Adaptive + Chosen Ciphertext attack (AKA Bleichenbacher attack) + against RSA, which when exploited, may result in + plaintext recovery of encrypted messages and/or a + Man-in-the-middle (MiTM) attack, despite the attacker not + having gained access to the server’s private key + itself. <url + href="https://nvd.nist.gov/vuln/detail/CVE-2017-1000385">CVE-2017-1000385</url> + </p> <p> Exploiting this vulnerability to perform + plaintext recovery of encrypted messages will, in most + practical cases, allow an attacker to read the plaintext + only after the session has completed. Only TLS sessions + established using RSA key exchange are vulnerable to this + attack. </p> <p> Exploiting this vulnerability to conduct + a MiTM attack requires the attacker to complete the + initial attack, which may require thousands of server + requests, during the handshake phase of the targeted + session within the window of the configured handshake + timeout. This attack may be conducted against any TLS + session using RSA signatures, but only if cipher suites + using RSA key exchange are also enabled on the server. + The limited window of opportunity, limitations in + bandwidth, and latency make this attack significantly + more difficult to execute. </p> <p> RSA key exchange is + enabled by default although least prioritized if server + order is honored. For such a cipher suite to be chosen it + must also be supported by the client and probably the + only shared cipher suite. </p> <p> Captured TLS sessions + encrypted with ephemeral cipher suites (DHE or ECDHE) are + not at risk for subsequent decryption due to this + vulnerability. </p> <p> As a workaround if default cipher + suite configuration was used you can configure the server + to not use vulnerable suites with the ciphers option like + this: </p> <c> {ciphers, [Suite || Suite <- + ssl:cipher_suites(), element(1,Suite) =/= rsa]} </c> <p> + that is your code will look somethingh like this: </p> + <c> ssl:listen(Port, [{ciphers, [Suite || Suite <- + ssl:cipher_suites(), element(1,S) =/= rsa]} | Options]). + </c> <p> Thanks to Hanno Böck, Juraj Somorovsky and + Craig Young for reporting this vulnerability. </p> + <p> + Own Id: OTP-14748</p> + </item> + </list> + </section> + + </section> <section><title>Improvements and New Features</title> <list> <item> diff --git a/lib/ssl/doc/src/pkix_certs.xml b/lib/ssl/doc/src/pkix_certs.xml deleted file mode 100644 index f365acef4d..0000000000 --- a/lib/ssl/doc/src/pkix_certs.xml +++ /dev/null @@ -1,59 +0,0 @@ -<?xml version="1.0" encoding="utf-8" ?> -<!DOCTYPE chapter SYSTEM "chapter.dtd"> - -<chapter> - <header> - <copyright> - <year>2003</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>PKIX Certificates</title> - <prepared>UAB/F/P Peter Högfeldt</prepared> - <docno></docno> - <date>2003-06-09</date> - <rev>A</rev> - <file>pkix_certs.xml</file> - </header> - - <section> - <title>Introduction to Certificates</title> - <p>Certificates were originally defined by ITU (CCITT) and the latest - definitions are described in <cite id="X.509"></cite>, but those definitions - are (as always) not working. - </p> - <p>Working certificate definitions for the Internet Community are found - in the the PKIX RFCs <cite id="rfc3279"></cite> and <cite id="rfc3280"></cite>. - The parsing of certificates in the Erlang/OTP SSL application is - based on those RFCS. - </p> - <p>Certificates are defined in terms of ASN.1 (<cite id="X.680"></cite>). - For an introduction to ASN.1 see <url href="http://asn1.elibel.tm.fr/">ASN.1 Information Site</url>. - </p> - </section> - - <section> - <title>PKIX Certificates</title> - <p>Certificate handling is now handled by the <c>public_key</c> application.</p> - <p> - DER encoded certificates returned by <c>ssl:peercert/1</c> can for example - be decoded by the <c>public_key:pkix_decode_cert/2</c> function. - </p> - </section> -</chapter> - - diff --git a/lib/ssl/doc/src/ssl.xml b/lib/ssl/doc/src/ssl.xml index e80fd59a7f..80b639155b 100644 --- a/lib/ssl/doc/src/ssl.xml +++ b/lib/ssl/doc/src/ssl.xml @@ -32,7 +32,7 @@ <modulesummary>Interface Functions for Secure Socket Layer</modulesummary> <description> <p> - This module contains interface functions for the SSL/TLS protocol. + This module contains interface functions for the SSL/TLS/DTLS protocol. For detailed information about the supported standards see <seealso marker="ssl_app">ssl(6)</seealso>. </p> @@ -40,7 +40,7 @@ <section> <title>DATA TYPES</title> - <p>The following data types are used in the functions for SSL:</p> + <p>The following data types are used in the functions for SSL/TLS/DTLS:</p> <taglist> @@ -56,9 +56,11 @@ <p>The default socket options are <c>[{mode,list},{packet, 0},{header, 0},{active, true}]</c>.</p> <p>For valid options, see the - <seealso marker="kernel:inet">inet(3)</seealso> and - <seealso marker="kernel:gen_tcp">gen_tcp(3)</seealso> manual pages - in Kernel.</p></item> + <seealso marker="kernel:inet">inet(3)</seealso>, + <seealso marker="kernel:gen_tcp">gen_tcp(3)</seealso> and + <seealso marker="kernel:gen_tcp">gen_udp(3)</seealso> + manual pages + in Kernel. Note that stream oriented options such as packet are only relevant for SSL/TLS and not DTLS</p></item> <tag><marker id="type-ssloption"/><c>ssl_option() =</c></tag> <item> @@ -69,7 +71,9 @@ <p><c>| {cert, public_key:der_encoded()}</c></p> <p><c>| {certfile, path()}</c></p> <p><c>| {key, {'RSAPrivateKey'| 'DSAPrivateKey' | 'ECPrivateKey' - | 'PrivateKeyInfo', public_key:der_encoded()}}</c></p> + | 'PrivateKeyInfo', public_key:der_encoded()} | + #{algorithm := rsa | dss | ecdsa, + engine := crypto:engine_ref(), key_id := crypto:key_id(), password => crypto:password()}</c></p> <p><c>| {keyfile, path()}</c></p> <p><c>| {password, string()}</c></p> <p><c>| {cacerts, [public_key:der_encoded()]}</c></p> @@ -93,13 +97,14 @@ <item><p><c>{cb_info, {CallbackModule::atom(), DataTag::atom(), ClosedTag::atom(), ErrTag:atom()}}</c></p> - <p>Defaults to <c>{gen_tcp, tcp, tcp_closed, tcp_error}</c>. Can be used - to customize the transport layer. The callback module must implement a + <p>Defaults to <c>{gen_tcp, tcp, tcp_closed, tcp_error}</c> for TLS + and <c>{gen_udp, udp, udp_closed, udp_error}</c> for DTLS. Can be used + to customize the transport layer. For TLS the callback module must implement a reliable transport protocol, behave as <c>gen_tcp</c>, and have functions corresponding to <c>inet:setopts/2</c>, <c>inet:getopts/2</c>, <c>inet:peername/1</c>, <c>inet:sockname/1</c>, and <c>inet:port/1</c>. The callback <c>gen_tcp</c> is treated specially and calls <c>inet</c> - directly.</p> + directly. For DTLS this feature must be considered exprimental.</p> <taglist> <tag><c>CallbackModule =</c></tag> <item><p><c>atom()</c></p></item> @@ -135,10 +140,16 @@ <tag><c>sslsocket() =</c></tag> <item><p>opaque()</p></item> - - <tag><marker id="type-protocol"/><c>protocol() =</c></tag> + + <tag><marker id="type-protocol"/><c> protocol_versions() =</c></tag> + <item><p><c> ssl_tls_protocol() | dtls_protocol() </c></p></item> + + <tag><marker id="type-protocol"/><c> ssl_tls_protocol() =</c></tag> <item><p><c>sslv3 | tlsv1 | 'tlsv1.1' | 'tlsv1.2'</c></p></item> + <tag><marker id="type-protocol"/><c> dtls_protocol() =</c></tag> + <item><p><c>'dtlsv1' | 'dtlsv1.2'</c></p></item> + <tag><c>ciphers() =</c></tag> <item><p><c>= [ciphersuite()] | string()</c></p> <p>According to old API.</p></item> @@ -182,7 +193,7 @@ </section> <section> - <title>SSL OPTION DESCRIPTIONS - COMMON for SERVER and CLIENT</title> + <title>TLS/DTLS OPTION DESCRIPTIONS - COMMON for SERVER and CLIENT</title> <p>The following options have the same meaning in the client and the server:</p> @@ -201,9 +212,15 @@ <tag><c>{certfile, path()}</c></tag> <item><p>Path to a file containing the user certificate.</p></item> - <tag><c>{key, {'RSAPrivateKey'| 'DSAPrivateKey' | 'ECPrivateKey' - |'PrivateKeyInfo', public_key:der_encoded()}}</c></tag> - <item><p>The DER-encoded user's private key. If this option + <tag> + <marker id="key_option_def"/> + <c>{key, {'RSAPrivateKey'| 'DSAPrivateKey' | 'ECPrivateKey' + |'PrivateKeyInfo', public_key:der_encoded()} | #{algorithm := rsa | dss | ecdsa, + engine := crypto:engine_ref(), key_id := crypto:key_id(), password => crypto:password()}</c></tag> + <item><p>The DER-encoded user's private key or a map refering to a crypto + engine and its key reference that optionally can be password protected, + seealso <seealso marker="crypto:crypto#engine_load-4"> crypto:engine_load/4 + </seealso> and <seealso marker="crypto:engine_load"> Crypto's Users Guide</seealso>. If this option is supplied, it overrides option <c>keyfile</c>.</p></item> <tag><c>{keyfile, path()}</c></tag> @@ -281,11 +298,11 @@ atom()}} | <list type="bulleted"> <item><p>If the verify callback fun returns <c>{fail, Reason}</c>, the verification process is immediately stopped, an alert is - sent to the peer, and the TLS/SSL handshake terminates.</p></item> + sent to the peer, and the TLS/DTLS handshake terminates.</p></item> <item><p>If the verify callback fun returns <c>{valid, UserState}</c>, the verification process continues.</p></item> <item><p>If the verify callback fun always returns - <c>{valid, UserState}</c>, the TLS/SSL handshake does not + <c>{valid, UserState}</c>, the TLS/DTLS handshake does not terminate regarding verification failures and the connection is established.</p></item> <item><p>If called with an extension unknown to the user application, @@ -448,15 +465,15 @@ marker="public_key:public_key#pkix_path_validation-3">public_key:pkix_path_valid marker="public_key:public_key#pkix_path_validation-3">public_key:pkix_path_validation/3</seealso> with the selected CA as trusted anchor and the rest of the chain.</p></item> - <tag><c>{versions, [protocol()]}</c></tag> + <tag><c>{versions, [protocol_versions()]}</c></tag> <item><p>TLS protocol versions supported by started clients and servers. This option overrides the application environment option - <c>protocol_version</c>. If the environment option is not set, it defaults + <c>protocol_version</c> and <c>dtls_protocol_version</c>. If the environment option is not set, it defaults to all versions, except SSL-3.0, supported by the SSL application. See also <seealso marker="ssl:ssl_app">ssl(6).</seealso></p></item> <tag><c>{hibernate_after, integer()|undefined}</c></tag> - <item><p>When an integer-value is specified, <c>ssl_connection</c> + <item><p>When an integer-value is specified, <c>TLS/DTLS-connection</c> goes into hibernation after the specified number of milliseconds of inactivity, thus reducing its memory footprint. When <c>undefined</c> is specified (this is the default), the process @@ -516,7 +533,7 @@ fun(srp, Username :: string(), UserState :: term()) -> </section> <section> - <title>SSL OPTION DESCRIPTIONS - CLIENT SIDE</title> + <title>TLS/DTLS OPTION DESCRIPTIONS - CLIENT SIDE</title> <p>The following options are client-specific or have a slightly different meaning in the client than in the server:</p> @@ -656,7 +673,7 @@ fun(srp, Username :: string(), UserState :: term()) -> </section> <section> - <title>SSL OPTION DESCRIPTIONS - SERVER SIDE</title> + <title>TLS/DTLS OPTION DESCRIPTIONS - SERVER SIDE</title> <p>The following options are server-specific or have a slightly different meaning in the server than in the client:</p> @@ -694,7 +711,7 @@ fun(srp, Username :: string(), UserState :: term()) -> </p></item> <tag><c>{fail_if_no_peer_cert, boolean()}</c></tag> - <item><p>Used together with <c>{verify, verify_peer}</c> by an SSL server. + <item><p>Used together with <c>{verify, verify_peer}</c> by an TLS/DTLS server. If set to <c>true</c>, the server fails if the client does not have a certificate to send, that is, sends an empty certificate. If set to <c>false</c>, it fails only if the client sends an invalid @@ -708,7 +725,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <tag><c>{reuse_session, fun(SuggestedSessionId, PeerCert, Compression, CipherSuite) -> boolean()}</c></tag> - <item><p>Enables the SSL server to have a local policy + <item><p>Enables the TLS/DTLS server to have a local policy for deciding if a session is to be reused or not. Meaningful only if <c>reuse_sessions</c> is set to <c>true</c>. <c>SuggestedSessionId</c> is a <c>binary()</c>, <c>PeerCert</c> is @@ -806,7 +823,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <section> <title>General</title> - <p>When an SSL socket is in active mode (the default), data from the + <p>When an TLS/DTLS socket is in active mode (the default), data from the socket is delivered to the owner of the socket in the form of messages:</p> @@ -824,6 +841,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <func> <name>cipher_suites() -></name> <name>cipher_suites(Type) -> ciphers()</name> + <name>cipher_suites(Type, protocol_version()) -> ciphers()</name> <fsummary>Returns a list of supported cipher suites.</fsummary> <type> <v>Type = erlang | openssl | all</v> @@ -835,13 +853,14 @@ fun(srp, Username :: string(), UserState :: term()) -> all available cipher suites. The cipher suites not present in <c>cipher_suites(erlang)</c> but included in <c>cipher_suites(all)</c> are not used unless explicitly configured - by the user.</p> + by the user. If the version option is not specified, the highest supported + TLS version will be used to determine the supported cipher suites</p> </desc> </func> <func> <name>eccs() -></name> - <name>eccs(protocol()) -> [named_curve()]</name> + <name>eccs(protocol_version()) -> [named_curve()]</name> <fsummary>Returns a list of supported ECCs.</fsummary> <desc><p>Returns a list of supported ECCs. <c>eccs()</c> @@ -849,7 +868,7 @@ fun(srp, Username :: string(), UserState :: term()) -> supported protocols and then deduplicating the output.</p> </desc> </func> - + <func> <name>clear_pem_cache() -> ok </name> <fsummary> Clears the pem cache</fsummary> @@ -864,20 +883,20 @@ fun(srp, Username :: string(), UserState :: term()) -> <func> <name>connect(Socket, SslOptions) -> </name> - <name>connect(Socket, SslOptions, Timeout) -> {ok, SslSocket} + <name>connect(Socket, SslOptions, Timeout) -> {ok, TLSSocket} | {error, Reason}</name> <fsummary>Upgrades a <c>gen_tcp</c>, or - equivalent, connected socket to an SSL socket.</fsummary> + equivalent, connected socket to an TLS socket.</fsummary> <type> <v>Socket = socket()</v> <v>SslOptions = [ssl_option()]</v> <v>Timeout = integer() | infinity</v> - <v>SslSocket = sslsocket()</v> + <v>TLSSocket = sslsocket()</v> <v>Reason = term()</v> </type> <desc><p>Upgrades a <c>gen_tcp</c>, or equivalent, - connected socket to an SSL socket, that is, performs the - client-side ssl handshake.</p> + connected socket to an TLS socket, that is, performs the + client-side TLS handshake.</p> <note><p>If the option <c>verify</c> is set to <c>verify_peer</c> the option <c>server_name_indication</c> shall also be specified, @@ -891,7 +910,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <name>connect(Host, Port, Options) -></name> <name>connect(Host, Port, Options, Timeout) -> {ok, SslSocket} | {error, Reason}</name> - <fsummary>Opens an SSL connection to <c>Host</c>, <c>Port</c>.</fsummary> + <fsummary>Opens an TLS/DTLS connection to <c>Host</c>, <c>Port</c>.</fsummary> <type> <v>Host = host()</v> <v>Port = integer()</v> @@ -900,13 +919,13 @@ fun(srp, Username :: string(), UserState :: term()) -> <v>SslSocket = sslsocket()</v> <v>Reason = term()</v> </type> - <desc><p>Opens an SSL connection to <c>Host</c>, <c>Port</c>.</p> + <desc><p>Opens an TLS/DTLS connection to <c>Host</c>, <c>Port</c>.</p> <p> When the option <c>verify</c> is set to <c>verify_peer</c> the check <seealso marker="public_key:public_key#pkix_verify_hostname-2">public_key:pkix_verify_hostname/2</seealso> will be performed in addition to the usual x509-path validation checks. If the check fails the error {bad_cert, hostname_check_failed} will be propagated to the path validation fun <seealso marker="#verify_fun">verify_fun</seealso>, where it is possible to do customized - checks by using the full possibilitis of the <seealso marker="public_key:public_key#pkix_verify_hostname-2">public_key:pkix_verify_hostname/2</seealso> API. + checks by using the full possibilities of the <seealso marker="public_key:public_key#pkix_verify_hostname-3">public_key:pkix_verify_hostname/3</seealso> API. When the option <c>server_name_indication</c> is provided, its value (the DNS name) will be used as <c>ReferenceID</c> to <seealso marker="public_key:public_key#pkix_verify_hostname-2">public_key:pkix_verify_hostname/2</seealso>. @@ -922,24 +941,24 @@ fun(srp, Username :: string(), UserState :: term()) -> <func> <name>close(SslSocket) -> ok | {error, Reason}</name> - <fsummary>Closes an SSL connection.</fsummary> + <fsummary>Closes an TLS/DTLS connection.</fsummary> <type> <v>SslSocket = sslsocket()</v> <v>Reason = term()</v> </type> - <desc><p>Closes an SSL connection.</p> + <desc><p>Closes an TLS/DTLS connection.</p> </desc> </func> <func> <name>close(SslSocket, How) -> ok | {ok, port()} | {error, Reason}</name> - <fsummary>Closes an SSL connection.</fsummary> + <fsummary>Closes an TLS connection.</fsummary> <type> <v>SslSocket = sslsocket()</v> <v>How = timeout() | {NewController::pid(), timeout()} </v> <v>Reason = term()</v> </type> - <desc><p>Closes or downgrades an SSL connection. In the latter case the transport + <desc><p>Closes or downgrades an TLS connection. In the latter case the transport connection will be handed over to the <c>NewController</c> process after receiving the TLS close alert from the peer. The returned transport socket will have the following options set: <c>[{active, false}, {packet, 0}, {mode, binary}]</c></p> @@ -950,7 +969,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <name>controlling_process(SslSocket, NewOwner) -> ok | {error, Reason}</name> <fsummary>Assigns a new controlling process to the - SSL socket.</fsummary> + TLS/DTLS socket.</fsummary> <type> <v>SslSocket = sslsocket()</v> <v>NewOwner = pid()</v> @@ -1113,7 +1132,7 @@ fun(srp, Username :: string(), UserState :: term()) -> extra key material. It either takes user-generated values for <c>Secret</c> and <c>Seed</c> or atoms directing it to use a specific value from the session security parameters.</p> - <p>Can only be used with TLS connections; <c>{error, undefined}</c> + <p>Can only be used with TLS/DTLS connections; <c>{error, undefined}</c> is returned for SSLv3 connections.</p> </desc> </func> @@ -1213,7 +1232,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <v>Reason = term()</v> </type> <desc> - <p>Performs the SSL/TLS server-side handshake.</p> + <p>Performs the SSL/TLS/DTLS server-side handshake.</p> <p><c>Socket</c> is a socket as returned by <seealso marker="#transport_accept-2">ssl:transport_accept/[1,2]</seealso> </p> @@ -1223,7 +1242,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <func> <name>ssl_accept(Socket, SslOptions) -> </name> <name>ssl_accept(Socket, SslOptions, Timeout) -> {ok, Socket} | ok | {error, Reason}</name> - <fsummary>Performs server-side SSL/TLS handshake.</fsummary> + <fsummary>Performs server-side SSL/TLS/DTLS handshake.</fsummary> <type> <v>Socket = socket() | sslsocket() </v> <v>SslOptions = [ssl_option()]</v> @@ -1240,10 +1259,10 @@ fun(srp, Username :: string(), UserState :: term()) -> by calling this function, else the upgrade succeeds or does not succeed depending on timing.</p></warning> - <p>If <c>Socket</c> is an <c>sslsocket()</c>: provides extra SSL/TLS + <p>If <c>Socket</c> is an <c>sslsocket()</c>: provides extra SSL/TLS/DTLS options to those specified in <seealso marker="#listen-2">ssl:listen/2 </seealso> and then performs - the SSL/TLS handshake. + the SSL/TLS/DTLS handshake. </p> </desc> </func> @@ -1302,7 +1321,7 @@ fun(srp, Username :: string(), UserState :: term()) -> The socket returned is to be passed to <seealso marker="#ssl_accept-2"> ssl:ssl_accept[2,3]</seealso> to complete handshaking, that is, - establishing the SSL/TLS connection.</p> + establishing the SSL/TLS/DTLS connection.</p> <warning> <p>The socket returned can only be used with <seealso marker="#ssl_accept-2"> ssl:ssl_accept[2,3]</seealso>. @@ -1324,7 +1343,8 @@ fun(srp, Username :: string(), UserState :: term()) -> <fsummary>Returns version information relevant for the SSL application.</fsummary> <type> - <v>versions_info() = {app_vsn, string()} | {supported | available, [protocol()] </v> + <v>versions_info() = {app_vsn, string()} | {supported | available, [ssl_tls_protocol()]} | + {supported_dtls | available_dtls, [dtls_protocol()]} </v> </type> <desc> <p>Returns version information relevant for the SSL @@ -1334,19 +1354,35 @@ fun(srp, Username :: string(), UserState :: term()) -> <item>The application version of the SSL application.</item> <tag><c>supported</c></tag> - <item>TLS/SSL versions supported by default. + <item>SSL/TLS versions supported by default. Overridden by a version option on <seealso marker="#connect-2"> connect/[2,3,4]</seealso>, <seealso marker="#listen-2"> listen/2</seealso>, and <seealso marker="#ssl_accept-2">ssl_accept/[1,2,3]</seealso>. - For the negotiated TLS/SSL version, see <seealso + For the negotiated SSL/TLS version, see <seealso marker="#connection_information-1">ssl:connection_information/1 </seealso>.</item> - + + <tag><c>supported_dtls</c></tag> + <item>DTLS versions supported by default. + Overridden by a version option on + <seealso marker="#connect-2"> connect/[2,3,4]</seealso>, + <seealso marker="#listen-2"> listen/2</seealso>, and <seealso + marker="#ssl_accept-2">ssl_accept/[1,2,3]</seealso>. + For the negotiated DTLS version, see <seealso + marker="#connection_information-1">ssl:connection_information/1 + </seealso>.</item> + <tag><c>available</c></tag> - <item>All TLS/SSL versions supported by the SSL application. + <item>All SSL/TLS versions supported by the SSL application. TLS 1.2 requires sufficient support from the Crypto application.</item> + + <tag><c>available_dtls</c></tag> + <item>All DTLS versions supported by the SSL application. + DTLS 1.2 requires sufficient support from the Crypto + application.</item> + </taglist> </desc> </func> @@ -1357,6 +1393,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <title>SEE ALSO</title> <p><seealso marker="kernel:inet">inet(3)</seealso> and <seealso marker="kernel:gen_tcp">gen_tcp(3)</seealso> + <seealso marker="kernel:gen_udp">gen_udp(3)</seealso> </p> </section> diff --git a/lib/ssl/doc/src/ssl_app.xml b/lib/ssl/doc/src/ssl_app.xml index f317dfded4..51070bb083 100644 --- a/lib/ssl/doc/src/ssl_app.xml +++ b/lib/ssl/doc/src/ssl_app.xml @@ -35,16 +35,20 @@ <description> <p> - The ssl application is an implementation of the SSL/TLS protocol in Erlang. + The ssl application is an implementation of the SSL/TLS/DTLS protocol in Erlang. </p> <list type="bulleted"> - <item>Supported SSL/TLS-versions are SSL-3.0, TLS-1.0, - TLS-1.1, and TLS-1.2.</item> + <item>Supported SSL/TLS/DTLS-versions are SSL-3.0, TLS-1.0, + TLS-1.1, TLS-1.2, DTLS-1.0 (based on TLS-1.1), DTLS-1.2 (based on TLS-1.2)</item> <item>For security reasons SSL-2.0 is not supported.</item> <item>For security reasons SSL-3.0 is no longer supported by default, - but can be configured.</item> + but can be configured. (OTP 19) </item> + <item>For security reasons RSA key exchange cipher suites are no longer supported by default, + but can be configured. (OTP 21) </item> <item>For security reasons DES cipher suites are no longer supported by default, - but can be configured.</item> + but can be configured. (OTP 20) </item> + <item>For security reasons 3DES cipher suites are no longer supported by default, + but can be configured. (OTP 21) </item> <item> Renegotiation Indication Extension <url href="http://www.ietf.org/rfc/rfc5746.txt">RFC 5746</url> is supported </item> <item>Ephemeral Diffie-Hellman cipher suites are supported, @@ -72,7 +76,7 @@ <section> <title>DEPENDENCIES</title> - <p>The SSL application uses the <c>public_key</c> and + <p>The SSL application uses the <c>public_key</c>, <c>asn1</c> and Crypto application to handle public keys and encryption, hence these applications must be loaded for the SSL application to work. In an embedded environment this means they must be started with @@ -94,13 +98,20 @@ <p><c>erl -ssl protocol_version "['tlsv1.2', 'tlsv1.1']"</c></p> <taglist> - <tag><c>protocol_version = </c><seealso marker="ssl#type-protocol">ssl:protocol()</seealso><c><![CDATA[<optional>]]></c></tag> + <tag><c>protocol_version = </c><seealso marker="ssl#type-protocol">ssl:ssl_tls_protocol()</seealso><c><![CDATA[<optional>]]></c></tag> <item><p>Protocol supported by started clients and servers. If this option is not set, it defaults to all - protocols currently supported by the SSL application. + TLS protocols currently supported by the SSL application. This option can be overridden by the version option to <c>ssl:connect/[2,3]</c> and <c>ssl:listen/2</c>.</p></item> + <tag><c>dtls_protocol_version = </c><seealso marker="ssl#type-protocol">ssl:dtls_protocol()</seealso><c><![CDATA[<optional>]]></c></tag> + <item><p>Protocol supported by started clients and + servers. If this option is not set, it defaults to all + DTLS protocols currently supported by the SSL application. + This option can be overridden by the version option + to <c>ssl:connect/[2,3]</c> and <c>ssl:listen/2</c>.</p></item> + <tag><c><![CDATA[session_lifetime = integer() <optional>]]></c></tag> <item><p>Maximum lifetime of the session data in seconds. Defaults to 24 hours which is the maximum recommended lifetime by <url href="http://www.ietf.org/rfc/5246rfc.txt">RFC 5246</url>. However @@ -123,14 +134,14 @@ new client connections. If the maximum number of sessions is reached, the current cache entries will be invalidated regardless of their remaining lifetime. Defaults to - 1000.</p></item> + 1000. Recommended ssl-8.2.1 or later for this option to work as intended.</p></item> <tag> <c><![CDATA[session_cache_server_max = integer() <optional>]]></c></tag> <item><p>Limits the growth of the servers session cache, that is how many client sessions are cached by the server. If the maximum number of sessions is reached, the current cache entries will be invalidated regardless of their remaining - lifetime. Defaults to 1000.</p></item> + lifetime. Defaults to 1000. Recommended ssl-8.2.1 or later for this option to work as intended.</p></item> <tag><c><![CDATA[ssl_pem_cache_clean = integer() <optional>]]></c></tag> <item> @@ -145,9 +156,8 @@ <tag><c><![CDATA[bypass_pem_cache = boolean() <optional>]]></c></tag> <item> <p>Introduced in ssl-8.0.2. Disables the PEM-cache. - The PEM cache has proven to be a bottleneck, until the - implementation has been improved this can be used as - a workaround. Defaults to false. + Can be used as a workaround for the PEM-cache bottleneck + before ssl-8.1.1. Defaults to false. </p> </item> @@ -167,7 +177,7 @@ <title>ERROR LOGGER AND EVENT HANDLERS</title> <p>The SSL application uses the default <seealso marker="kernel:error_logger">OTP error logger</seealso> to log - unexpected errors and TLS alerts. The logging of TLS alerts may be + unexpected errors and TLS/DTLS alerts. The logging of TLS/DTLS alerts may be turned off with the <c>log_alert</c> option. </p> </section> diff --git a/lib/ssl/doc/src/ssl_distribution.xml b/lib/ssl/doc/src/ssl_distribution.xml index 61f88e3860..e14f3f90dc 100644 --- a/lib/ssl/doc/src/ssl_distribution.xml +++ b/lib/ssl/doc/src/ssl_distribution.xml @@ -4,7 +4,7 @@ <chapter> <header> <copyright> - <year>2000</year><year>2016</year> + <year>2000</year><year>2017</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -22,7 +22,7 @@ </legalnotice> - <title>Using SSL for Erlang Distribution</title> + <title>Using TLS for Erlang Distribution</title> <prepared>P Nyblom</prepared> <responsible></responsible> <docno></docno> @@ -33,7 +33,7 @@ <file>ssl_distribution.xml</file> </header> <p>This section describes how the Erlang distribution can use - SSL to get extra verification and security.</p> + TLS to get extra verification and security.</p> <p>The Erlang distribution can in theory use almost any connection-based protocol as bearer. However, a module that @@ -45,16 +45,16 @@ <p>In the SSL application, an extra distribution module, <c>inet_tls_dist</c>, can be used as an - alternative. All distribution connections will use SSL and + alternative. All distribution connections will use TLS and all participating Erlang nodes in a distributed system must use this distribution module.</p> <p>The security level depends on the parameters provided to the - SSL connection setup. Erlang node cookies are however always + TLS connection setup. Erlang node cookies are however always used, as they can be used to differentiate between two different Erlang networks.</p> - <p>To set up Erlang distribution over SSL:</p> + <p>To set up Erlang distribution over TLS:</p> <list type="bulleted"> <item><em>Step 1:</em> Build boot scripts including the @@ -63,13 +63,13 @@ <c>net_kernel</c>.</item> <item><em>Step 3:</em> Specify the security options and other SSL options.</item> - <item><em>Step 4:</em> Set up the environment to always use SSL.</item> + <item><em>Step 4:</em> Set up the environment to always use TLS.</item> </list> <p>The following sections describe these steps.</p> <section> - <title>Building Boot Scripts Including the ssl Application</title> + <title>Building Boot Scripts Including the SSL Application</title> <p>Boot scripts are built using the <c>systools</c> utility in the SASL application. For more information on <c>systools</c>, see the SASL documentation. This is only an example of @@ -90,7 +90,7 @@ STDLIB application.</p></item> </list> - <p>The following shows an example <c>.rel</c> file with SSL + <p>The following shows an example <c>.rel</c> file with TLS added:</p> <code type="none"> {release, {"OTP APN 181 01","R15A"}, {erts, "5.9"}, @@ -154,7 +154,7 @@ Eshell V5.0 (abort with ^G) <section> <title>Specifying Distribution Module for net_kernel</title> - <p>The distribution module for SSL is named <c>inet_tls_dist</c> + <p>The distribution module for SSL/TLS is named <c>inet_tls_dist</c> and is specified on the command line with option <c>-proto_dist</c>. The argument to <c>-proto_dist</c> is to be the module name without suffix <c>_dist</c>. So, this distribution @@ -174,21 +174,107 @@ Eshell V5.0 (abort with ^G) (ssl_test@myhost)1> </code> <p>However, a node started in this way refuses to talk - to other nodes, as no SSL parameters are supplied + to other nodes, as no TLS parameters are supplied (see the next section).</p> </section> <section> - <title>Specifying SSL Options</title> - <p>For SSL to work, at least - a public key and a certificate must be specified for the server - side. In the following example, the PEM-files consist of two - entries, the server certificate and its private key.</p> + <title>Specifying SSL/TLS Options</title> + + <p> + The SSL/TLS distribution options can be written into a file + that is consulted when the node is started. This file name + is then specified with the command line argument + <c>-ssl_dist_optfile</c>. + </p> + <p> + Any available SSL/TLS option can be specified in an options file, + but note that options that take a <c>fun()</c> has to use + the syntax <c>fun Mod:Func/Arity</c> since a function + body can not be compiled when consulting a file. + </p> + <p> + Do not tamper with the socket options + <c>list</c>, <c>binary</c>, <c>active</c>, <c>packet</c>, + <c>nodelay</c> and <c>deliver</c> since they are used + by the distribution protocol handler itself. + Other raw socket options such as <c>packet_size</c> may + interfere severely, so beware! + </p> + <p> + For SSL/TLS to work, at least a public key and a certificate + must be specified for the server side. + In the following example, the PEM file + <c>"/home/me/ssl/erlserver.pem"</c> contains both + the server certificate and its private key. + </p> + <p> + Create a file named for example + <c>"/home/me/ssl/[email protected]"</c>: + </p> + <code type="none"><![CDATA[ +[{server, + [{certfile, "/home/me/ssl/erlserver.pem"}, + {secure_renegotiate, true}]}, + {client, + [{secure_renegotiate, true}]}].]]> + </code> + <p> + And then start the node like this + (line breaks in the command are for readability, + and shall not be there when typed): + </p> + <code type="none"><![CDATA[ +$ erl -boot /home/me/ssl/start_ssl -proto_dist inet_tls + -ssl_dist_optfile "/home/me/ssl/[email protected]" + -sname ssl_test]]> + </code> + <p> + The options in the <c>{server, Opts}</c> tuple are used + when calling <c>ssl:ssl_accept/3</c>, and the options in the + <c>{client, Opts}</c> tuple are used when calling + <c>ssl:connect/4</c>. + </p> + <p> + For the client, the option + <c>{server_name_indication, atom_to_list(TargetNode)}</c> + is added when connecting. + This makes it possible to use the client option + <c>{verify, verify_peer}</c>, + and the client will verify that the certificate matches + the node name you are connecting to. + This only works if the the server certificate is issued + to the name <c>atom_to_list(TargetNode)</c>. + </p> + <p> + For the server it is also possible to use the option + <c>{verify, verify_peer}</c> and the server will only accept + client connections with certificates that are trusted by + a root certificate that the server knows. + A client that presents an untrusted certificate will be rejected. + This option is preferably combined with + <c>{fail_if_no_peer_cert, true}</c> or a client will + still be accepted if it does not present any certificate. + </p> + <p> + A node started in this way is fully functional, using TLS + as the distribution protocol. + </p> + </section> + + <section> + <title>Specifying SSL/TLS Options (Legacy)</title> + + <p> + As in the previous section the PEM file + <c>"/home/me/ssl/erlserver.pem"</c> contains both + the server certificate and its private key. + </p> <p>On the <c>erl</c> command line you can specify options that the - SSL distribution adds when creating a socket.</p> + SSL/TLS distribution adds when creating a socket.</p> - <p>The simplest SSL options in the following list can be specified + <p>The simplest SSL/TLS options in the following list can be specified by adding the prefix <c>server_</c> or <c>client_</c> to the option name:</p> <list type="bulleted"> @@ -208,7 +294,7 @@ Eshell V5.0 (abort with ^G) </list> <p>Note that <c>verify_fun</c> needs to be written in a different - form than the corresponding SSL option, since funs are not + form than the corresponding SSL/TLS option, since funs are not accepted on the command line.</p> <p>The server can also take the options <c>dhfile</c> and @@ -221,32 +307,34 @@ Eshell V5.0 (abort with ^G) <p>Raw socket options, such as <c>packet</c> and <c>size</c> must not be specified on the command line.</p> - <p>The command-line argument for specifying the SSL options is named + <p>The command-line argument for specifying the SSL/TLS options is named <c>-ssl_dist_opt</c> and is to be followed by pairs of SSL options and their values. Argument <c>-ssl_dist_opt</c> can be repeated any number of times.</p> - <p>An example command line can now look as follows + <p> + An example command line doing the same as the example + in the previous section can now look as follows (line breaks in the command are for readability, - and are not be there when typed):</p> - <code type="none"> + and shall not be there when typed): + </p> + <code type="none"><![CDATA[ $ erl -boot /home/me/ssl/start_ssl -proto_dist inet_tls - -ssl_dist_opt server_certfile "/home/me/ssl/erlserver.pem" + -ssl_dist_opt server_certfile "/home/me/ssl/erlserver.pem" -ssl_dist_opt server_secure_renegotiate true client_secure_renegotiate true -sname ssl_test Erlang (BEAM) emulator version 5.0 [source] - + Eshell V5.0 (abort with ^G) -(ssl_test@myhost)1> </code> - <p>A node started in this way is fully functional, using SSL - as the distribution protocol.</p> +(ssl_test@myhost)1>]]> + </code> </section> <section> - <title>Setting up Environment to Always Use SSL</title> + <title>Setting up Environment to Always Use SSL/TLS (Legacy)</title> <p>A convenient way to specify arguments to Erlang is to use environment variable <c>ERL_FLAGS</c>. All the flags needed to - use the SSL distribution can be specified in that variable and are + use the SSL/TLS distribution can be specified in that variable and are then interpreted as command-line arguments for all subsequent invocations of Erlang.</p> @@ -277,25 +365,21 @@ Eshell V5.0 (abort with ^G) </section> <section> - <title>Using SSL distribution over IPv6</title> - <p>It is possible to use SSL distribution over IPv6 instead of + <title>Using SSL/TLS distribution over IPv6</title> + <p>It is possible to use SSL/TLS distribution over IPv6 instead of IPv4. To do this, pass the option <c>-proto_dist inet6_tls</c> instead of <c>-proto_dist inet_tls</c> when starting Erlang, either on the command line or in the <c>ERL_FLAGS</c> environment variable.</p> <p>An example command line with this option would look like this:</p> - <code type="none"> + <code type="none"><![CDATA[ $ erl -boot /home/me/ssl/start_ssl -proto_dist inet6_tls - -ssl_dist_opt server_certfile "/home/me/ssl/erlserver.pem" - -ssl_dist_opt server_secure_renegotiate true client_secure_renegotiate true - -sname ssl_test -Erlang (BEAM) emulator version 5.0 [source] - -Eshell V5.0 (abort with ^G) -(ssl_test@myhost)1> </code> + -ssl_dist_optfile "/home/me/ssl/[email protected]" + -sname ssl_test]]> + </code> <p>A node started in this way will only be able to communicate with - other nodes using SSL distribution over IPv6.</p> + other nodes using SSL/TLS distribution over IPv6.</p> </section> </chapter> diff --git a/lib/ssl/doc/src/ssl_introduction.xml b/lib/ssl/doc/src/ssl_introduction.xml index d3e39dbb01..a416924eb1 100644 --- a/lib/ssl/doc/src/ssl_introduction.xml +++ b/lib/ssl/doc/src/ssl_introduction.xml @@ -5,7 +5,7 @@ <header> <copyright> <year>2015</year> - <year>2015</year> + <year>2017</year> <holder>Ericsson AB, All Rights Reserved</holder> </copyright> <legalnotice> @@ -36,19 +36,20 @@ <title>Purpose</title> <p>Transport Layer Security (TLS) and its predecessor, the Secure Sockets Layer (SSL), are cryptographic protocols designed to - provide communications security over a computer network. The protocols use + provide communications security over a computer network. The protocols use X.509 certificates and hence public key (asymmetric) cryptography to authenticate the counterpart with whom they communicate, and to exchange a symmetric key for payload encryption. The protocol provides data/message confidentiality (encryption), integrity (through message authentication code checks) - and host verification (through certificate path validation).</p> + and host verification (through certificate path validation). DTLS (Datagram Transport Layer Security) that + is based on TLS but datagram oriented instead of stream oriented.</p> </section> <section> <title>Prerequisites</title> <p>It is assumed that the reader is familiar with the Erlang programming language, the concepts of OTP, and has a basic - understanding of SSL/TLS.</p> + understanding of SSL/TLS/DTLS.</p> </section> </chapter> diff --git a/lib/ssl/doc/src/ssl_protocol.xml b/lib/ssl/doc/src/ssl_protocol.xml index 31a22db58b..0b12dc7dc5 100644 --- a/lib/ssl/doc/src/ssl_protocol.xml +++ b/lib/ssl/doc/src/ssl_protocol.xml @@ -22,7 +22,7 @@ </legalnotice> - <title>TLS and its Predecessor, SSL</title> + <title>TLS/DTLS and TLS Predecessor, SSL</title> <prepared></prepared> <responsible></responsible> <docno></docno> @@ -33,7 +33,7 @@ <file>ssl_protocol.xml</file> </header> - <p>The Erlang SSL application implements the SSL/TLS protocol + <p>The Erlang SSL application implements the SSL/TLS/DTLS protocol for the currently supported versions, see the <seealso marker="ssl">ssl(3)</seealso> manual page. </p> @@ -41,20 +41,22 @@ <p>By default SSL/TLS is run over the TCP/IP protocol even though you can plug in any other reliable transport protocol with the same Application Programming Interface (API) as the - <c>gen_tcp</c> module in Kernel.</p> + <c>gen_tcp</c> module in Kernel. DTLS is by default run over UDP/IP, + which means that application data has no delivery guarentees. Other + transports, such as SCTP, may be supported in future releases.</p> <p>If a client and a server wants to use an upgrade mechanism, such as - defined by RFC 2817, to upgrade a regular TCP/IP connection to an SSL + defined by RFC 2817, to upgrade a regular TCP/IP connection to an TLS connection, this is supported by the Erlang SSL application API. This can be useful for, for example, supporting HTTP and HTTPS on the same port and - implementing virtual hosting. + implementing virtual hosting. Note this is a TLS feature only. </p> <section> <title>Security Overview</title> <p>To achieve authentication and privacy, the client and server - perform a TLS handshake procedure before transmitting or receiving + perform a TLS/DTLS handshake procedure before transmitting or receiving any data. During the handshake, they agree on a protocol version and cryptographic algorithms, generate shared secrets using public key cryptographies, and optionally authenticate each other with @@ -73,10 +75,10 @@ <p>The keys for the symmetric encryption are generated uniquely for each connection and are based on a secret negotiated - in the TLS handshake.</p> + in the TLS/DTLS handshake.</p> - <p>The TLS handshake protocol and data transfer is run on top of - the TLS Record Protocol, which uses a keyed-hash Message + <p>The TLS/DTLS handshake protocol and data transfer is run on top of + the TLS/DTLS Record Protocol, which uses a keyed-hash Message Authenticity Code (MAC), or a Hash-based MAC (HMAC), to protect the message data integrity. From the TLS RFC: "A Message Authentication Code is a @@ -152,8 +154,8 @@ from it was saved, for security reasons. The amount of time the session data is to be saved can be configured.</p> - <p>By default the SSL clients try to reuse an available session and - by default the SSL servers agree to reuse sessions when clients + <p>By default the TLS/DTLS clients try to reuse an available session and + by default the TLS/DTLS servers agree to reuse sessions when clients ask for it.</p> </section> diff --git a/lib/ssl/doc/src/using_ssl.xml b/lib/ssl/doc/src/using_ssl.xml index f84cd6e391..c369c3c133 100644 --- a/lib/ssl/doc/src/using_ssl.xml +++ b/lib/ssl/doc/src/using_ssl.xml @@ -22,7 +22,7 @@ </legalnotice> - <title>Using SSL API</title> + <title>Using SSL application API</title> <prepared></prepared> <responsible></responsible> <docno></docno> @@ -51,7 +51,7 @@ <section> <title>Minimal Example</title> - <note><p> The minimal setup is not the most secure setup of SSL.</p> + <note><p> The minimal setup is not the most secure setup of SSL/TLS/DTLS.</p> </note> <p>To set up client/server connections:</p> @@ -60,27 +60,27 @@ <code type="erl">1 server> ssl:start(). ok</code> - <p><em>Step 2:</em> Create an SSL listen socket:</p> + <p><em>Step 2:</em> Create an TLS listen socket: (To run DTLS add the option {protocol, dtls})</p> <code type="erl">2 server> {ok, ListenSocket} = ssl:listen(9999, [{certfile, "cert.pem"}, {keyfile, "key.pem"},{reuseaddr, true}]). {ok,{sslsocket, [...]}}</code> - <p><em>Step 3:</em> Do a transport accept on the SSL listen socket:</p> + <p><em>Step 3:</em> Do a transport accept on the TLS listen socket:</p> <code type="erl">3 server> {ok, Socket} = ssl:transport_accept(ListenSocket). {ok,{sslsocket, [...]}}</code> - <p><em>Step 4:</em> Start the client side:</p> + <p><em>Step 4:</em> Start the client side: </p> <code type="erl">1 client> ssl:start(). ok</code> - + <p> To run DTLS add the option {protocol, dtls} to third argument.</p> <code type="erl">2 client> {ok, Socket} = ssl:connect("localhost", 9999, [], infinity). {ok,{sslsocket, [...]}}</code> - <p><em>Step 5:</em> Do the SSL handshake:</p> + <p><em>Step 5:</em> Do the TLS handshake:</p> <code type="erl">4 server> ok = ssl:ssl_accept(Socket). ok</code> - <p><em>Step 6:</em> Send a message over SSL:</p> + <p><em>Step 6:</em> Send a message over TLS:</p> <code type="erl">5 server> ssl:send(Socket, "foo"). ok</code> @@ -92,7 +92,7 @@ ok</code> </section> <section> - <title>Upgrade Example</title> + <title>Upgrade Example - TLS only </title> <note><p>To upgrade a TCP/IP connection to an SSL connection, the client and server must agree to do so. The agreement @@ -125,24 +125,24 @@ ok</code> <code type="erl">4 server> inet:setopts(Socket, [{active, false}]). ok</code> - <p><em>Step 6:</em> Do the SSL handshake:</p> - <code type="erl">5 server> {ok, SSLSocket} = ssl:ssl_accept(Socket, [{cacertfile, "cacerts.pem"}, + <p><em>Step 6:</em> Do the TLS handshake:</p> + <code type="erl">5 server> {ok, TLSSocket} = ssl:ssl_accept(Socket, [{cacertfile, "cacerts.pem"}, {certfile, "cert.pem"}, {keyfile, "key.pem"}]). {ok,{sslsocket,[...]}}</code> - <p><em>Step 7:</em> Upgrade to an SSL connection. The client and server + <p><em>Step 7:</em> Upgrade to an TLS connection. The client and server must agree upon the upgrade. The server must call <c>ssl:accept/2</c> before the client calls <c>ssl:connect/3.</c></p> - <code type="erl">3 client>{ok, SSLSocket} = ssl:connect(Socket, [{cacertfile, "cacerts.pem"}, + <code type="erl">3 client>{ok, TLSSocket} = ssl:connect(Socket, [{cacertfile, "cacerts.pem"}, {certfile, "cert.pem"}, {keyfile, "key.pem"}], infinity). {ok,{sslsocket,[...]}}</code> - <p><em>Step 8:</em> Send a message over SSL:</p> - <code type="erl">4 client> ssl:send(SSLSocket, "foo"). + <p><em>Step 8:</em> Send a message over TLS:</p> + <code type="erl">4 client> ssl:send(TLSSocket, "foo"). ok</code> - <p><em>Step 9:</em> Set <c>active true</c> on the SSL socket:</p> - <code type="erl">4 server> ssl:setopts(SSLSocket, [{active, true}]). + <p><em>Step 9:</em> Set <c>active true</c> on the TLS socket:</p> + <code type="erl">4 server> ssl:setopts(TLSSocket, [{active, true}]). ok</code> <p><em>Step 10:</em> Flush the shell message queue to see that the message @@ -152,4 +152,41 @@ Shell got {ssl,{sslsocket,[...]},"foo"} ok</code> </section> </section> + + <section> + <title>Using an Engine Stored Key</title> + + <p>Erlang ssl application is able to use private keys provided + by OpenSSL engines using the following mechanism:</p> + + <code type="erl">1> ssl:start(). +ok</code> + + <p>Load a crypto engine, should be done once per engine used. For example + dynamically load the engine called <c>MyEngine</c>: + </p> + <code type="erl">2> {ok, EngineRef} = +crypto:engine_load(<<"dynamic">>, + [{<<"SO_PATH">>, "/tmp/user/engines/MyEngine"},<<"LOAD">>],[]). +{ok,#Ref<0.2399045421.3028942852.173962>} + </code> + + <p>Create a map with the engine information and the algorithm used by the engine:</p> + <code type="erl">3> PrivKey = + #{algorithm => rsa, + engine => EngineRef, + key_id => "id of the private key in Engine"}. + </code> + <p>Use the map in the ssl key option:</p> + <code type="erl">4> {ok, SSLSocket} = +ssl:connect("localhost", 9999, + [{cacertfile, "cacerts.pem"}, + {certfile, "cert.pem"}, + {key, PrivKey}], infinity). + </code> + + <p>See also <seealso marker="crypto:engine_load#engine_load"> crypto documentation</seealso> </p> + + </section> + </chapter> diff --git a/lib/ssl/src/dtls_connection.erl b/lib/ssl/src/dtls_connection.erl index 387d632ef8..fb12a729b1 100644 --- a/lib/ssl/src/dtls_connection.erl +++ b/lib/ssl/src/dtls_connection.erl @@ -39,20 +39,18 @@ -export([start_fsm/8, start_link/7, init/1]). %% State transition handling --export([next_record/1, next_event/3, next_event/4]). +-export([next_record/1, next_event/3, next_event/4, handle_common_event/4]). %% Handshake handling --export([renegotiate/2, - reinit_handshake_data/1, - send_handshake/2, queue_handshake/2, queue_change_cipher/2, - select_sni_extension/1, empty_connection_state/2]). +-export([renegotiate/2, send_handshake/2, + queue_handshake/2, queue_change_cipher/2, + reinit_handshake_data/1, select_sni_extension/1, empty_connection_state/2]). %% Alert and close handling -export([encode_alert/3,send_alert/2, close/5, protocol_name/0]). %% Data handling - --export([encode_data/3, passive_receive/2, next_record_if_active/1, handle_common_event/4, +-export([encode_data/3, passive_receive/2, next_record_if_active/1, send/3, socket/5, setopts/3, getopts/3]). %% gen_statem state functions @@ -64,6 +62,9 @@ %%==================================================================== %% Internal application API +%%==================================================================== +%%==================================================================== +%% Setup %%==================================================================== start_fsm(Role, Host, Port, Socket, {#ssl_options{erl_dist = false},_, Tracker} = Opts, User, {CbModule, _,_, _} = CbInfo, @@ -79,6 +80,224 @@ start_fsm(Role, Host, Port, Socket, {#ssl_options{erl_dist = false},_, Tracker} Error end. +%%-------------------------------------------------------------------- +-spec start_link(atom(), host(), inet:port_number(), port(), list(), pid(), tuple()) -> + {ok, pid()} | ignore | {error, reason()}. +%% +%% Description: Creates a gen_statem process which calls Module:init/1 to +%% initialize. +%%-------------------------------------------------------------------- +start_link(Role, Host, Port, Socket, Options, User, CbInfo) -> + {ok, proc_lib:spawn_link(?MODULE, init, [[Role, Host, Port, Socket, Options, User, CbInfo]])}. + +init([Role, Host, Port, Socket, Options, User, CbInfo]) -> + process_flag(trap_exit, true), + State0 = initial_state(Role, Host, Port, Socket, Options, User, CbInfo), + try + State = ssl_connection:ssl_config(State0#state.ssl_options, Role, State0), + gen_statem:enter_loop(?MODULE, [], init, State) + catch + throw:Error -> + gen_statem:enter_loop(?MODULE, [], error, {Error,State0}) + end. +%%==================================================================== +%% State transition handling +%%==================================================================== +next_record(#state{unprocessed_handshake_events = N} = State) when N > 0 -> + {no_record, State#state{unprocessed_handshake_events = N-1}}; + +next_record(#state{protocol_buffers = + #protocol_buffers{dtls_cipher_texts = [#ssl_tls{epoch = Epoch} = CT | Rest]} + = Buffers, + connection_states = #{current_read := #{epoch := Epoch}} = ConnectionStates} = State) -> + CurrentRead = dtls_record:get_connection_state_by_epoch(Epoch, ConnectionStates, read), + case dtls_record:replay_detect(CT, CurrentRead) of + false -> + decode_cipher_text(State#state{connection_states = ConnectionStates}) ; + true -> + %% Ignore replayed record + next_record(State#state{protocol_buffers = + Buffers#protocol_buffers{dtls_cipher_texts = Rest}, + connection_states = ConnectionStates}) + end; +next_record(#state{protocol_buffers = + #protocol_buffers{dtls_cipher_texts = [#ssl_tls{epoch = Epoch} | Rest]} + = Buffers, + connection_states = #{current_read := #{epoch := CurrentEpoch}} = ConnectionStates} = State) + when Epoch > CurrentEpoch -> + %% TODO Buffer later Epoch message, drop it for now + next_record(State#state{protocol_buffers = + Buffers#protocol_buffers{dtls_cipher_texts = Rest}, + connection_states = ConnectionStates}); +next_record(#state{protocol_buffers = + #protocol_buffers{dtls_cipher_texts = [ _ | Rest]} + = Buffers, + connection_states = ConnectionStates} = State) -> + %% Drop old epoch message + next_record(State#state{protocol_buffers = + Buffers#protocol_buffers{dtls_cipher_texts = Rest}, + connection_states = ConnectionStates}); +next_record(#state{role = server, + socket = {Listener, {Client, _}}, + transport_cb = gen_udp} = State) -> + dtls_udp_listener:active_once(Listener, Client, self()), + {no_record, State}; +next_record(#state{role = client, + socket = {_Server, Socket} = DTLSSocket, + close_tag = CloseTag, + transport_cb = Transport} = State) -> + case dtls_socket:setopts(Transport, Socket, [{active,once}]) of + ok -> + {no_record, State}; + _ -> + self() ! {CloseTag, DTLSSocket}, + {no_record, State} + end; +next_record(State) -> + {no_record, State}. + +next_event(StateName, Record, State) -> + next_event(StateName, Record, State, []). + +next_event(connection = StateName, no_record, + #state{connection_states = #{current_read := #{epoch := CurrentEpoch}}} = State0, Actions) -> + case next_record_if_active(State0) of + {no_record, State} -> + ssl_connection:hibernate_after(StateName, State, Actions); + {#ssl_tls{epoch = CurrentEpoch, + type = ?HANDSHAKE, + version = Version} = Record, State1} -> + State = dtls_version(StateName, Version, State1), + {next_state, StateName, State, + [{next_event, internal, {protocol_record, Record}} | Actions]}; + {#ssl_tls{epoch = CurrentEpoch} = Record, State} -> + {next_state, StateName, State, [{next_event, internal, {protocol_record, Record}} | Actions]}; + {#ssl_tls{epoch = Epoch, + type = ?HANDSHAKE, + version = _Version}, State1} = _Record when Epoch == CurrentEpoch-1 -> + {State2, MoreActions} = send_handshake_flight(State1, CurrentEpoch), + {NextRecord, State} = next_record(State2), + next_event(StateName, NextRecord, State, Actions ++ MoreActions); + %% From FLIGHT perspective CHANGE_CIPHER_SPEC is treated as a handshake + {#ssl_tls{epoch = Epoch, + type = ?CHANGE_CIPHER_SPEC, + version = _Version}, State1} = _Record when Epoch == CurrentEpoch-1 -> + {State2, MoreActions} = send_handshake_flight(State1, CurrentEpoch), + {NextRecord, State} = next_record(State2), + next_event(StateName, NextRecord, State, Actions ++ MoreActions); + {#ssl_tls{epoch = _Epoch, + version = _Version}, State1} -> + %% TODO maybe buffer later epoch + {Record, State} = next_record(State1), + next_event(StateName, Record, State, Actions); + {#alert{} = Alert, State} -> + {next_state, StateName, State, [{next_event, internal, Alert} | Actions]} + end; +next_event(connection = StateName, Record, + #state{connection_states = #{current_read := #{epoch := CurrentEpoch}}} = State0, Actions) -> + case Record of + #ssl_tls{epoch = CurrentEpoch, + type = ?HANDSHAKE, + version = Version} = Record -> + State = dtls_version(StateName, Version, State0), + {next_state, StateName, State, + [{next_event, internal, {protocol_record, Record}} | Actions]}; + #ssl_tls{epoch = CurrentEpoch} -> + {next_state, StateName, State0, [{next_event, internal, {protocol_record, Record}} | Actions]}; + #ssl_tls{epoch = Epoch, + type = ?HANDSHAKE, + version = _Version} when Epoch == CurrentEpoch-1 -> + {State1, MoreActions} = send_handshake_flight(State0, CurrentEpoch), + {NextRecord, State} = next_record(State1), + next_event(StateName, NextRecord, State, Actions ++ MoreActions); + %% From FLIGHT perspective CHANGE_CIPHER_SPEC is treated as a handshake + #ssl_tls{epoch = Epoch, + type = ?CHANGE_CIPHER_SPEC, + version = _Version} when Epoch == CurrentEpoch-1 -> + {State1, MoreActions} = send_handshake_flight(State0, CurrentEpoch), + {NextRecord, State} = next_record(State1), + next_event(StateName, NextRecord, State, Actions ++ MoreActions); + _ -> + next_event(StateName, no_record, State0, Actions) + end; +next_event(StateName, Record, + #state{connection_states = #{current_read := #{epoch := CurrentEpoch}}} = State0, Actions) -> + case Record of + no_record -> + {next_state, StateName, State0, Actions}; + #ssl_tls{epoch = CurrentEpoch, + version = Version} = Record -> + State = dtls_version(StateName, Version, State0), + {next_state, StateName, State, + [{next_event, internal, {protocol_record, Record}} | Actions]}; + #ssl_tls{epoch = _Epoch, + version = _Version} = _Record -> + %% TODO maybe buffer later epoch + {Record, State} = next_record(State0), + next_event(StateName, Record, State, Actions); + #alert{} = Alert -> + {next_state, StateName, State0, [{next_event, internal, Alert} | Actions]} + end. + +handle_common_event(internal, #alert{} = Alert, StateName, + #state{negotiated_version = Version} = State) -> + handle_own_alert(Alert, Version, StateName, State); +%%% DTLS record protocol level handshake messages +handle_common_event(internal, #ssl_tls{type = ?HANDSHAKE, + fragment = Data}, + StateName, + #state{protocol_buffers = Buffers0, + negotiated_version = Version} = State0) -> + try + case dtls_handshake:get_dtls_handshake(Version, Data, Buffers0) of + {[], Buffers} -> + {Record, State} = next_record(State0#state{protocol_buffers = Buffers}), + next_event(StateName, Record, State); + {Packets, Buffers} -> + State = State0#state{protocol_buffers = Buffers}, + Events = dtls_handshake_events(Packets), + {next_state, StateName, + State#state{unprocessed_handshake_events = unprocessed_events(Events)}, Events} + end + catch throw:#alert{} = Alert -> + handle_own_alert(Alert, Version, StateName, State0) + end; +%%% DTLS record protocol level application data messages +handle_common_event(internal, #ssl_tls{type = ?APPLICATION_DATA, fragment = Data}, StateName, State) -> + {next_state, StateName, State, [{next_event, internal, {application_data, Data}}]}; +%%% DTLS record protocol level change cipher messages +handle_common_event(internal, #ssl_tls{type = ?CHANGE_CIPHER_SPEC, fragment = Data}, StateName, State) -> + {next_state, StateName, State, [{next_event, internal, #change_cipher_spec{type = Data}}]}; +%%% DTLS record protocol level Alert messages +handle_common_event(internal, #ssl_tls{type = ?ALERT, fragment = EncAlerts}, StateName, + #state{negotiated_version = Version} = State) -> + case decode_alerts(EncAlerts) of + Alerts = [_|_] -> + handle_alerts(Alerts, {next_state, StateName, State}); + #alert{} = Alert -> + handle_own_alert(Alert, Version, StateName, State) + end; +%% Ignore unknown TLS record level protocol messages +handle_common_event(internal, #ssl_tls{type = _Unknown}, StateName, State) -> + {next_state, StateName, State}. + +%%==================================================================== +%% Handshake handling +%%==================================================================== + +renegotiate(#state{role = client} = State, Actions) -> + %% Handle same way as if server requested + %% the renegotiation + {next_state, connection, State, + [{next_event, internal, #hello_request{}} | Actions]}; + +renegotiate(#state{role = server} = State0, Actions) -> + HelloRequest = ssl_handshake:hello_request(), + State1 = prepare_flight(State0), + {State2, MoreActions} = send_handshake(HelloRequest, State1), + {Record, State} = next_record(State2), + next_event(hello, Record, State, Actions ++ MoreActions). + send_handshake(Handshake, #state{connection_states = ConnectionStates} = State) -> #{epoch := Epoch} = ssl_record:current_connection_state(ConnectionStates, write), send_handshake_flight(queue_handshake(Handshake, State), Epoch). @@ -104,85 +323,12 @@ queue_handshake(Handshake0, #state{tls_handshake_history = Hist0, next_sequence => Seq +1}, tls_handshake_history = Hist}. - -send_handshake_flight(#state{socket = Socket, - transport_cb = Transport, - flight_buffer = #{handshakes := Flight, - change_cipher_spec := undefined}, - negotiated_version = Version, - connection_states = ConnectionStates0} = State0, Epoch) -> - %% TODO remove hardcoded Max size - {Encoded, ConnectionStates} = - encode_handshake_flight(lists:reverse(Flight), Version, 1400, Epoch, ConnectionStates0), - send(Transport, Socket, Encoded), - {State0#state{connection_states = ConnectionStates}, []}; - -send_handshake_flight(#state{socket = Socket, - transport_cb = Transport, - flight_buffer = #{handshakes := [_|_] = Flight0, - change_cipher_spec := ChangeCipher, - handshakes_after_change_cipher_spec := []}, - negotiated_version = Version, - connection_states = ConnectionStates0} = State0, Epoch) -> - {HsBefore, ConnectionStates1} = - encode_handshake_flight(lists:reverse(Flight0), Version, 1400, Epoch, ConnectionStates0), - {EncChangeCipher, ConnectionStates} = encode_change_cipher(ChangeCipher, Version, Epoch, ConnectionStates1), - - send(Transport, Socket, [HsBefore, EncChangeCipher]), - {State0#state{connection_states = ConnectionStates}, []}; - -send_handshake_flight(#state{socket = Socket, - transport_cb = Transport, - flight_buffer = #{handshakes := [_|_] = Flight0, - change_cipher_spec := ChangeCipher, - handshakes_after_change_cipher_spec := Flight1}, - negotiated_version = Version, - connection_states = ConnectionStates0} = State0, Epoch) -> - {HsBefore, ConnectionStates1} = - encode_handshake_flight(lists:reverse(Flight0), Version, 1400, Epoch-1, ConnectionStates0), - {EncChangeCipher, ConnectionStates2} = - encode_change_cipher(ChangeCipher, Version, Epoch-1, ConnectionStates1), - {HsAfter, ConnectionStates} = - encode_handshake_flight(lists:reverse(Flight1), Version, 1400, Epoch, ConnectionStates2), - send(Transport, Socket, [HsBefore, EncChangeCipher, HsAfter]), - {State0#state{connection_states = ConnectionStates}, []}; - -send_handshake_flight(#state{socket = Socket, - transport_cb = Transport, - flight_buffer = #{handshakes := [], - change_cipher_spec := ChangeCipher, - handshakes_after_change_cipher_spec := Flight1}, - negotiated_version = Version, - connection_states = ConnectionStates0} = State0, Epoch) -> - {EncChangeCipher, ConnectionStates1} = - encode_change_cipher(ChangeCipher, Version, Epoch-1, ConnectionStates0), - {HsAfter, ConnectionStates} = - encode_handshake_flight(lists:reverse(Flight1), Version, 1400, Epoch, ConnectionStates1), - send(Transport, Socket, [EncChangeCipher, HsAfter]), - {State0#state{connection_states = ConnectionStates}, []}. - queue_change_cipher(ChangeCipher, #state{flight_buffer = Flight, connection_states = ConnectionStates0} = State) -> ConnectionStates = dtls_record:next_epoch(ConnectionStates0, write), State#state{flight_buffer = Flight#{change_cipher_spec => ChangeCipher}, connection_states = ConnectionStates}. - -send_alert(Alert, #state{negotiated_version = Version, - socket = Socket, - transport_cb = Transport, - connection_states = ConnectionStates0} = State0) -> - {BinMsg, ConnectionStates} = - encode_alert(Alert, Version, ConnectionStates0), - send(Transport, Socket, BinMsg), - State0#state{connection_states = ConnectionStates}. - -close(downgrade, _,_,_,_) -> - ok; -%% Other -close(_, Socket, Transport, _,_) -> - dtls_socket:close(Transport,Socket). - reinit_handshake_data(#state{protocol_buffers = Buffers} = State) -> State#state{premaster_secret = undefined, public_key_info = undefined, @@ -200,54 +346,81 @@ select_sni_extension(#client_hello{extensions = HelloExtensions}) -> HelloExtensions#hello_extensions.sni; select_sni_extension(_) -> undefined. + empty_connection_state(ConnectionEnd, BeastMitigation) -> Empty = ssl_record:empty_connection_state(ConnectionEnd, BeastMitigation), dtls_record:empty_connection_state(Empty). -socket(Pid, Transport, Socket, Connection, _) -> - dtls_socket:socket(Pid, Transport, Socket, Connection). +%%==================================================================== +%% Alert and close handling +%%==================================================================== +encode_alert(#alert{} = Alert, Version, ConnectionStates) -> + dtls_record:encode_alert_record(Alert, Version, ConnectionStates). -setopts(Transport, Socket, Other) -> - dtls_socket:setopts(Transport, Socket, Other). -getopts(Transport, Socket, Tag) -> - dtls_socket:getopts(Transport, Socket, Tag). +send_alert(Alert, #state{negotiated_version = Version, + socket = Socket, + transport_cb = Transport, + connection_states = ConnectionStates0} = State0) -> + {BinMsg, ConnectionStates} = + encode_alert(Alert, Version, ConnectionStates0), + send(Transport, Socket, BinMsg), + State0#state{connection_states = ConnectionStates}. + +close(downgrade, _,_,_,_) -> + ok; +%% Other +close(_, Socket, Transport, _,_) -> + dtls_socket:close(Transport,Socket). protocol_name() -> "DTLS". %%==================================================================== -%% tls_connection_sup API -%%==================================================================== +%% Data handling +%%==================================================================== -%%-------------------------------------------------------------------- --spec start_link(atom(), host(), inet:port_number(), port(), list(), pid(), tuple()) -> - {ok, pid()} | ignore | {error, reason()}. -%% -%% Description: Creates a gen_fsm process which calls Module:init/1 to -%% initialize. To ensure a synchronized start-up procedure, this function -%% does not return until Module:init/1 has returned. -%%-------------------------------------------------------------------- -start_link(Role, Host, Port, Socket, Options, User, CbInfo) -> - {ok, proc_lib:spawn_link(?MODULE, init, [[Role, Host, Port, Socket, Options, User, CbInfo]])}. +encode_data(Data, Version, ConnectionStates0)-> + dtls_record:encode_data(Data, Version, ConnectionStates0). -init([Role, Host, Port, Socket, Options, User, CbInfo]) -> - process_flag(trap_exit, true), - State0 = initial_state(Role, Host, Port, Socket, Options, User, CbInfo), - try - State = ssl_connection:ssl_config(State0#state.ssl_options, Role, State0), - gen_statem:enter_loop(?MODULE, [], init, State) - catch - throw:Error -> - gen_statem:enter_loop(?MODULE, [], error, {Error,State0}) +passive_receive(State0 = #state{user_data_buffer = Buffer}, StateName) -> + case Buffer of + <<>> -> + {Record, State} = next_record(State0), + next_event(StateName, Record, State); + _ -> + {Record, State} = ssl_connection:read_application_data(<<>>, State0), + next_event(StateName, Record, State) end. +next_record_if_active(State = + #state{socket_options = + #socket_options{active = false}}) -> + {no_record ,State}; -callback_mode() -> - [state_functions, state_enter]. +next_record_if_active(State) -> + next_record(State). + +send(Transport, {_, {{_,_}, _} = Socket}, Data) -> + send(Transport, Socket, Data); +send(Transport, Socket, Data) -> + dtls_socket:send(Transport, Socket, Data). + +socket(Pid, Transport, Socket, Connection, _) -> + dtls_socket:socket(Pid, Transport, Socket, Connection). + +setopts(Transport, Socket, Other) -> + dtls_socket:setopts(Transport, Socket, Other). + +getopts(Transport, Socket, Tag) -> + dtls_socket:getopts(Transport, Socket, Tag). %%-------------------------------------------------------------------- %% State functions %%-------------------------------------------------------------------- - +%%-------------------------------------------------------------------- +-spec init(gen_statem:event_type(), + {start, timeout()} | term(), #state{}) -> + gen_statem:state_function_result(). +%%-------------------------------------------------------------------- init(enter, _, State) -> {keep_state, State}; init({call, From}, {start, Timeout}, @@ -277,28 +450,33 @@ init({call, From}, {start, Timeout}, {Record, State} = next_record(State3), next_event(hello, Record, State, Actions); init({call, _} = Type, Event, #state{role = server, transport_cb = gen_udp} = State) -> - Result = ssl_connection:?FUNCTION_NAME(Type, Event, - State#state{flight_state = {retransmit, ?INITIAL_RETRANSMIT_TIMEOUT}, - protocol_specific = #{current_cookie_secret => dtls_v1:cookie_secret(), - previous_cookie_secret => <<>>, - ignored_alerts => 0, - max_ignored_alerts => 10}}, - ?MODULE), + Result = gen_handshake(?FUNCTION_NAME, Type, Event, + State#state{flight_state = {retransmit, ?INITIAL_RETRANSMIT_TIMEOUT}, + protocol_specific = #{current_cookie_secret => dtls_v1:cookie_secret(), + previous_cookie_secret => <<>>, + ignored_alerts => 0, + max_ignored_alerts => 10}}), erlang:send_after(dtls_v1:cookie_timeout(), self(), new_cookie_secret), Result; init({call, _} = Type, Event, #state{role = server} = State) -> %% I.E. DTLS over sctp - ssl_connection:?FUNCTION_NAME(Type, Event, State#state{flight_state = reliable}, ?MODULE); + gen_handshake(?FUNCTION_NAME, Type, Event, State#state{flight_state = reliable}); init(Type, Event, State) -> - ssl_connection:?FUNCTION_NAME(Type, Event, State, ?MODULE). - + gen_handshake(?FUNCTION_NAME, Type, Event, State). + +%%-------------------------------------------------------------------- +-spec error(gen_statem:event_type(), + {start, timeout()} | term(), #state{}) -> + gen_statem:state_function_result(). +%%-------------------------------------------------------------------- error(enter, _, State) -> {keep_state, State}; error({call, From}, {start, _Timeout}, {Error, State}) -> - {stop_and_reply, normal, {reply, From, {error, Error}}, State}; -error({call, From}, Msg, State) -> - handle_call(Msg, From, ?FUNCTION_NAME, State); + ssl_connection:stop_and_reply( + normal, {reply, From, {error, Error}}, State); +error({call, _} = Call, Msg, State) -> + gen_handshake(?FUNCTION_NAME, Call, Msg, State); error(_, _, _) -> {keep_state_and_data, [postpone]}. @@ -393,49 +571,66 @@ hello(internal, {handshake, {#hello_verify_request{} = Handshake, _}}, State) -> %% hello_verify should not be in handshake history {next_state, ?FUNCTION_NAME, State, [{next_event, internal, Handshake}]}; hello(info, Event, State) -> - handle_info(Event, ?FUNCTION_NAME, State); + gen_info(Event, ?FUNCTION_NAME, State); hello(state_timeout, Event, State) -> handle_state_timeout(Event, ?FUNCTION_NAME, State); hello(Type, Event, State) -> - ssl_connection:?FUNCTION_NAME(Type, Event, State, ?MODULE). + gen_handshake(?FUNCTION_NAME, Type, Event, State). +%%-------------------------------------------------------------------- +-spec abbreviated(gen_statem:event_type(), term(), #state{}) -> + gen_statem:state_function_result(). +%%-------------------------------------------------------------------- abbreviated(enter, _, State0) -> {State, Actions} = handle_flight_timer(State0), {keep_state, State, Actions}; abbreviated(info, Event, State) -> - handle_info(Event, ?FUNCTION_NAME, State); + gen_info(Event, ?FUNCTION_NAME, State); abbreviated(internal = Type, #change_cipher_spec{type = <<1>>} = Event, #state{connection_states = ConnectionStates0} = State) -> ConnectionStates1 = dtls_record:save_current_connection_state(ConnectionStates0, read), ConnectionStates = dtls_record:next_epoch(ConnectionStates1, read), - ssl_connection:?FUNCTION_NAME(Type, Event, State#state{connection_states = ConnectionStates}, ?MODULE); + gen_handshake(?FUNCTION_NAME, Type, Event, State#state{connection_states = ConnectionStates}); abbreviated(internal = Type, #finished{} = Event, #state{connection_states = ConnectionStates} = State) -> - ssl_connection:?FUNCTION_NAME(Type, Event, - prepare_flight(State#state{connection_states = ConnectionStates, - flight_state = connection}), ?MODULE); + gen_handshake(?FUNCTION_NAME, Type, Event, + prepare_flight(State#state{connection_states = ConnectionStates, + flight_state = connection})); abbreviated(state_timeout, Event, State) -> handle_state_timeout(Event, ?FUNCTION_NAME, State); abbreviated(Type, Event, State) -> - ssl_connection:?FUNCTION_NAME(Type, Event, State, ?MODULE). - + gen_handshake(?FUNCTION_NAME, Type, Event, State). +%%-------------------------------------------------------------------- +-spec certify(gen_statem:event_type(), term(), #state{}) -> + gen_statem:state_function_result(). +%%-------------------------------------------------------------------- certify(enter, _, State0) -> {State, Actions} = handle_flight_timer(State0), {keep_state, State, Actions}; certify(info, Event, State) -> - handle_info(Event, ?FUNCTION_NAME, State); + gen_info(Event, ?FUNCTION_NAME, State); certify(internal = Type, #server_hello_done{} = Event, State) -> ssl_connection:certify(Type, Event, prepare_flight(State), ?MODULE); +certify(internal, #change_cipher_spec{type = <<1>>}, State0) -> + {State1, Actions0} = send_handshake_flight(State0, retransmit_epoch(?FUNCTION_NAME, State0)), + {Record, State2} = next_record(State1), + {next_state, ?FUNCTION_NAME, State, Actions} = next_event(?FUNCTION_NAME, Record, State2, Actions0), + %% This will reset the retransmission timer by repeating the enter state event + {repeat_state, State, Actions}; certify(state_timeout, Event, State) -> handle_state_timeout(Event, ?FUNCTION_NAME, State); certify(Type, Event, State) -> - ssl_connection:?FUNCTION_NAME(Type, Event, State, ?MODULE). + gen_handshake(?FUNCTION_NAME, Type, Event, State). +%%-------------------------------------------------------------------- +-spec cipher(gen_statem:event_type(), term(), #state{}) -> + gen_statem:state_function_result(). +%%-------------------------------------------------------------------- cipher(enter, _, State0) -> {State, Actions} = handle_flight_timer(State0), {keep_state, State, Actions}; cipher(info, Event, State) -> - handle_info(Event, ?FUNCTION_NAME, State); + gen_info(Event, ?FUNCTION_NAME, State); cipher(internal = Type, #change_cipher_spec{type = <<1>>} = Event, #state{connection_states = ConnectionStates0} = State) -> ConnectionStates1 = dtls_record:save_current_connection_state(ConnectionStates0, read), @@ -451,10 +646,15 @@ cipher(state_timeout, Event, State) -> cipher(Type, Event, State) -> ssl_connection:?FUNCTION_NAME(Type, Event, State, ?MODULE). +%%-------------------------------------------------------------------- +-spec connection(gen_statem:event_type(), + #hello_request{} | #client_hello{}| term(), #state{}) -> + gen_statem:state_function_result(). +%%-------------------------------------------------------------------- connection(enter, _, State) -> {keep_state, State}; connection(info, Event, State) -> - handle_info(Event, ?FUNCTION_NAME, State); + gen_info(Event, ?FUNCTION_NAME, State); connection(internal, #hello_request{}, #state{host = Host, port = Port, session = #session{own_certificate = Cert} = Session0, session_cache = Cache, session_cache_cb = CacheCb, @@ -492,136 +692,24 @@ connection(Type, Event, State) -> ssl_connection:?FUNCTION_NAME(Type, Event, State, ?MODULE). %%TODO does this make sense for DTLS ? +%%-------------------------------------------------------------------- +-spec downgrade(gen_statem:event_type(), term(), #state{}) -> + gen_statem:state_function_result(). +%%-------------------------------------------------------------------- downgrade(enter, _, State) -> {keep_state, State}; downgrade(Type, Event, State) -> ssl_connection:?FUNCTION_NAME(Type, Event, State, ?MODULE). %%-------------------------------------------------------------------- -%% Description: This function is called by a gen_fsm when it receives any -%% other message than a synchronous or asynchronous event -%% (or a system message). +%% gen_statem callbacks %%-------------------------------------------------------------------- +callback_mode() -> + [state_functions, state_enter]. -%% raw data from socket, unpack records -handle_info({Protocol, _, _, _, Data}, StateName, - #state{data_tag = Protocol} = State0) -> - case next_dtls_record(Data, State0) of - {Record, State} -> - next_event(StateName, Record, State); - #alert{} = Alert -> - ssl_connection:handle_normal_shutdown(Alert, StateName, State0), - {stop, {shutdown, own_alert}} - end; -handle_info({CloseTag, Socket}, StateName, - #state{socket = Socket, - socket_options = #socket_options{active = Active}, - protocol_buffers = #protocol_buffers{dtls_cipher_texts = CTs}, - close_tag = CloseTag, - negotiated_version = Version} = State) -> - %% Note that as of DTLS 1.2 (TLS 1.1), - %% failure to properly close a connection no longer requires that a - %% session not be resumed. This is a change from DTLS 1.0 to conform - %% with widespread implementation practice. - case (Active == false) andalso (CTs =/= []) of - false -> - case Version of - {254, N} when N =< 253 -> - ok; - _ -> - %% As invalidate_sessions here causes performance issues, - %% we will conform to the widespread implementation - %% practice and go aginst the spec - %%invalidate_session(Role, Host, Port, Session) - ok - end, - ssl_connection:handle_normal_shutdown(?ALERT_REC(?FATAL, ?CLOSE_NOTIFY), StateName, State), - {stop, {shutdown, transport_closed}}; - true -> - %% Fixes non-delivery of final DTLS record in {active, once}. - %% Basically allows the application the opportunity to set {active, once} again - %% and then receive the final message. - next_event(StateName, no_record, State) - end; - -handle_info(new_cookie_secret, StateName, - #state{protocol_specific = #{current_cookie_secret := Secret} = CookieInfo} = State) -> - erlang:send_after(dtls_v1:cookie_timeout(), self(), new_cookie_secret), - {next_state, StateName, State#state{protocol_specific = - CookieInfo#{current_cookie_secret => dtls_v1:cookie_secret(), - previous_cookie_secret => Secret}}}; -handle_info(Msg, StateName, State) -> - ssl_connection:StateName(info, Msg, State, ?MODULE). - -handle_call(Event, From, StateName, State) -> - ssl_connection:handle_call(Event, From, StateName, State, ?MODULE). - -handle_common_event(internal, #alert{} = Alert, StateName, - #state{negotiated_version = Version} = State) -> - handle_own_alert(Alert, Version, StateName, State); -%%% DTLS record protocol level handshake messages -handle_common_event(internal, #ssl_tls{type = ?HANDSHAKE, - fragment = Data}, - StateName, - #state{protocol_buffers = Buffers0, - negotiated_version = Version} = State0) -> - try - case dtls_handshake:get_dtls_handshake(Version, Data, Buffers0) of - {[], Buffers} -> - {Record, State} = next_record(State0#state{protocol_buffers = Buffers}), - next_event(StateName, Record, State); - {Packets, Buffers} -> - State = State0#state{protocol_buffers = Buffers}, - Events = dtls_handshake_events(Packets), - {next_state, StateName, - State#state{unprocessed_handshake_events = unprocessed_events(Events)}, Events} - end - catch throw:#alert{} = Alert -> - handle_own_alert(Alert, Version, StateName, State0) - end; -%%% DTLS record protocol level application data messages -handle_common_event(internal, #ssl_tls{type = ?APPLICATION_DATA, fragment = Data}, StateName, State) -> - {next_state, StateName, State, [{next_event, internal, {application_data, Data}}]}; -%%% DTLS record protocol level change cipher messages -handle_common_event(internal, #ssl_tls{type = ?CHANGE_CIPHER_SPEC, fragment = Data}, StateName, State) -> - {next_state, StateName, State, [{next_event, internal, #change_cipher_spec{type = Data}}]}; -%%% DTLS record protocol level Alert messages -handle_common_event(internal, #ssl_tls{type = ?ALERT, fragment = EncAlerts}, StateName, - #state{negotiated_version = Version} = State) -> - case decode_alerts(EncAlerts) of - Alerts = [_|_] -> - handle_alerts(Alerts, {next_state, StateName, State}); - #alert{} = Alert -> - handle_own_alert(Alert, Version, StateName, State) - end; -%% Ignore unknown TLS record level protocol messages -handle_common_event(internal, #ssl_tls{type = _Unknown}, StateName, State) -> - {next_state, StateName, State}. - -handle_state_timeout(flight_retransmission_timeout, StateName, - #state{flight_state = {retransmit, NextTimeout}} = State0) -> - {State1, Actions} = send_handshake_flight(State0#state{flight_state = {retransmit, NextTimeout}}, - retransmit_epoch(StateName, State0)), - {Record, State} = next_record(State1), - next_event(StateName, Record, State, Actions). - -send(Transport, {_, {{_,_}, _} = Socket}, Data) -> - send(Transport, Socket, Data); -send(Transport, Socket, Data) -> - dtls_socket:send(Transport, Socket, Data). -%%-------------------------------------------------------------------- -%% Description:This function is called by a gen_fsm when it is about -%% to terminate. It should be the opposite of Module:init/1 and do any -%% necessary cleaning up. When it returns, the gen_fsm terminates with -%% Reason. The return value is ignored. -%%-------------------------------------------------------------------- terminate(Reason, StateName, State) -> ssl_connection:terminate(Reason, StateName, State). -%%-------------------------------------------------------------------- -%% code_change(OldVsn, StateName, State, Extra) -> {ok, StateName, NewState} -%% Description: Convert process state when code is changed -%%-------------------------------------------------------------------- code_change(_OldVsn, StateName, State, _Extra) -> {ok, StateName, State}. @@ -631,55 +719,6 @@ format_status(Type, Data) -> %%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- -handle_client_hello(#client_hello{client_version = ClientVersion} = Hello, - #state{connection_states = ConnectionStates0, - port = Port, session = #session{own_certificate = Cert} = Session0, - renegotiation = {Renegotiation, _}, - session_cache = Cache, - session_cache_cb = CacheCb, - negotiated_protocol = CurrentProtocol, - key_algorithm = KeyExAlg, - ssl_options = SslOpts} = State0) -> - - case dtls_handshake:hello(Hello, SslOpts, {Port, Session0, Cache, CacheCb, - ConnectionStates0, Cert, KeyExAlg}, Renegotiation) of - #alert{} = Alert -> - handle_own_alert(Alert, ClientVersion, hello, State0); - {Version, {Type, Session}, - ConnectionStates, Protocol0, ServerHelloExt, HashSign} -> - Protocol = case Protocol0 of - undefined -> CurrentProtocol; - _ -> Protocol0 - end, - - State = prepare_flight(State0#state{connection_states = ConnectionStates, - negotiated_version = Version, - hashsign_algorithm = HashSign, - session = Session, - negotiated_protocol = Protocol}), - - ssl_connection:hello(internal, {common_client_hello, Type, ServerHelloExt}, - State, ?MODULE) - end. - -encode_handshake_flight(Flight, Version, MaxFragmentSize, Epoch, ConnectionStates) -> - Fragments = lists:map(fun(Handshake) -> - dtls_handshake:fragment_handshake(Handshake, MaxFragmentSize) - end, Flight), - dtls_record:encode_handshake(Fragments, Version, Epoch, ConnectionStates). - -encode_change_cipher(#change_cipher_spec{}, Version, Epoch, ConnectionStates) -> - dtls_record:encode_change_cipher_spec(Version, Epoch, ConnectionStates). - -encode_data(Data, Version, ConnectionStates0)-> - dtls_record:encode_data(Data, Version, ConnectionStates0). - -encode_alert(#alert{} = Alert, Version, ConnectionStates) -> - dtls_record:encode_alert_record(Alert, Version, ConnectionStates). - -decode_alerts(Bin) -> - ssl_alert:decode(Bin). - initial_state(Role, Host, Port, Socket, {SSLOptions, SocketOptions, _}, User, {CbModule, DataTag, CloseTag, ErrorTag}) -> #ssl_options{beast_mitigation = BeastMitigation} = SSLOptions, @@ -720,10 +759,12 @@ initial_state(Role, Host, Port, Socket, {SSLOptions, SocketOptions, _}, User, flight_state = {retransmit, ?INITIAL_RETRANSMIT_TIMEOUT} }. -next_dtls_record(Data, #state{protocol_buffers = #protocol_buffers{ +next_dtls_record(Data, StateName, #state{protocol_buffers = #protocol_buffers{ dtls_record_buffer = Buf0, dtls_cipher_texts = CT0} = Buffers} = State0) -> - case dtls_record:get_dtls_records(Data, Buf0) of + case dtls_record:get_dtls_records(Data, + acceptable_record_versions(StateName, State0), + Buf0) of {Records, Buf1} -> CT1 = CT0 ++ Records, next_record(State0#state{protocol_buffers = @@ -733,153 +774,15 @@ next_dtls_record(Data, #state{protocol_buffers = #protocol_buffers{ Alert end. -next_record(#state{unprocessed_handshake_events = N} = State) when N > 0 -> - {no_record, State#state{unprocessed_handshake_events = N-1}}; - -next_record(#state{protocol_buffers = - #protocol_buffers{dtls_cipher_texts = [#ssl_tls{epoch = Epoch} = CT | Rest]} - = Buffers, - connection_states = #{current_read := #{epoch := Epoch}} = ConnectionStates} = State) -> - CurrentRead = dtls_record:get_connection_state_by_epoch(Epoch, ConnectionStates, read), - case dtls_record:replay_detect(CT, CurrentRead) of - false -> - decode_cipher_text(State#state{connection_states = ConnectionStates}) ; - true -> - %% Ignore replayed record - next_record(State#state{protocol_buffers = - Buffers#protocol_buffers{dtls_cipher_texts = Rest}, - connection_states = ConnectionStates}) - end; -next_record(#state{protocol_buffers = - #protocol_buffers{dtls_cipher_texts = [#ssl_tls{epoch = Epoch} | Rest]} - = Buffers, - connection_states = #{current_read := #{epoch := CurrentEpoch}} = ConnectionStates} = State) - when Epoch > CurrentEpoch -> - %% TODO Buffer later Epoch message, drop it for now - next_record(State#state{protocol_buffers = - Buffers#protocol_buffers{dtls_cipher_texts = Rest}, - connection_states = ConnectionStates}); -next_record(#state{protocol_buffers = - #protocol_buffers{dtls_cipher_texts = [ _ | Rest]} - = Buffers, - connection_states = ConnectionStates} = State) -> - %% Drop old epoch message - next_record(State#state{protocol_buffers = - Buffers#protocol_buffers{dtls_cipher_texts = Rest}, - connection_states = ConnectionStates}); -next_record(#state{role = server, - socket = {Listener, {Client, _}}, - transport_cb = gen_udp} = State) -> - dtls_udp_listener:active_once(Listener, Client, self()), - {no_record, State}; -next_record(#state{role = client, - socket = {_Server, Socket}, - transport_cb = Transport} = State) -> - dtls_socket:setopts(Transport, Socket, [{active,once}]), - {no_record, State}; -next_record(State) -> - {no_record, State}. - -next_record_if_active(State = - #state{socket_options = - #socket_options{active = false}}) -> - {no_record ,State}; - -next_record_if_active(State) -> - next_record(State). - -passive_receive(State0 = #state{user_data_buffer = Buffer}, StateName) -> - case Buffer of - <<>> -> - {Record, State} = next_record(State0), - next_event(StateName, Record, State); - _ -> - {Record, State} = ssl_connection:read_application_data(<<>>, State0), - next_event(StateName, Record, State) - end. - -next_event(StateName, Record, State) -> - next_event(StateName, Record, State, []). +acceptable_record_versions(hello, _) -> + [dtls_record:protocol_version(Vsn) || Vsn <- ?ALL_DATAGRAM_SUPPORTED_VERSIONS]; +acceptable_record_versions(_, #state{negotiated_version = Version}) -> + [Version]. -next_event(connection = StateName, no_record, - #state{connection_states = #{current_read := #{epoch := CurrentEpoch}}} = State0, Actions) -> - case next_record_if_active(State0) of - {no_record, State} -> - ssl_connection:hibernate_after(StateName, State, Actions); - {#ssl_tls{epoch = CurrentEpoch, - type = ?HANDSHAKE, - version = Version} = Record, State1} -> - State = dtls_version(StateName, Version, State1), - {next_state, StateName, State, - [{next_event, internal, {protocol_record, Record}} | Actions]}; - {#ssl_tls{epoch = CurrentEpoch} = Record, State} -> - {next_state, StateName, State, [{next_event, internal, {protocol_record, Record}} | Actions]}; - {#ssl_tls{epoch = Epoch, - type = ?HANDSHAKE, - version = _Version}, State1} = _Record when Epoch == CurrentEpoch-1 -> - {State2, MoreActions} = send_handshake_flight(State1, CurrentEpoch), - {NextRecord, State} = next_record(State2), - next_event(StateName, NextRecord, State, Actions ++ MoreActions); - %% From FLIGHT perspective CHANGE_CIPHER_SPEC is treated as a handshake - {#ssl_tls{epoch = Epoch, - type = ?CHANGE_CIPHER_SPEC, - version = _Version}, State1} = _Record when Epoch == CurrentEpoch-1 -> - {State2, MoreActions} = send_handshake_flight(State1, CurrentEpoch), - {NextRecord, State} = next_record(State2), - next_event(StateName, NextRecord, State, Actions ++ MoreActions); - {#ssl_tls{epoch = _Epoch, - version = _Version}, State1} -> - %% TODO maybe buffer later epoch - {Record, State} = next_record(State1), - next_event(StateName, Record, State, Actions); - {#alert{} = Alert, State} -> - {next_state, StateName, State, [{next_event, internal, Alert} | Actions]} - end; -next_event(connection = StateName, Record, - #state{connection_states = #{current_read := #{epoch := CurrentEpoch}}} = State0, Actions) -> - case Record of - #ssl_tls{epoch = CurrentEpoch, - type = ?HANDSHAKE, - version = Version} = Record -> - State = dtls_version(StateName, Version, State0), - {next_state, StateName, State, - [{next_event, internal, {protocol_record, Record}} | Actions]}; - #ssl_tls{epoch = CurrentEpoch} -> - {next_state, StateName, State0, [{next_event, internal, {protocol_record, Record}} | Actions]}; - #ssl_tls{epoch = Epoch, - type = ?HANDSHAKE, - version = _Version} when Epoch == CurrentEpoch-1 -> - {State1, MoreActions} = send_handshake_flight(State0, CurrentEpoch), - {NextRecord, State} = next_record(State1), - next_event(StateName, NextRecord, State, Actions ++ MoreActions); - %% From FLIGHT perspective CHANGE_CIPHER_SPEC is treated as a handshake - #ssl_tls{epoch = Epoch, - type = ?CHANGE_CIPHER_SPEC, - version = _Version} when Epoch == CurrentEpoch-1 -> - {State1, MoreActions} = send_handshake_flight(State0, CurrentEpoch), - {NextRecord, State} = next_record(State1), - next_event(StateName, NextRecord, State, Actions ++ MoreActions); - _ -> - next_event(StateName, no_record, State0, Actions) - end; -next_event(StateName, Record, - #state{connection_states = #{current_read := #{epoch := CurrentEpoch}}} = State0, Actions) -> - case Record of - no_record -> - {next_state, StateName, State0, Actions}; - #ssl_tls{epoch = CurrentEpoch, - version = Version} = Record -> - State = dtls_version(StateName, Version, State0), - {next_state, StateName, State, - [{next_event, internal, {protocol_record, Record}} | Actions]}; - #ssl_tls{epoch = _Epoch, - version = _Version} = _Record -> - %% TODO maybe buffer later epoch - {Record, State} = next_record(State0), - next_event(StateName, Record, State, Actions); - #alert{} = Alert -> - {next_state, StateName, State0, [{next_event, internal, Alert} | Actions]} - end. +dtls_handshake_events(Packets) -> + lists:map(fun(Packet) -> + {next_event, internal, {handshake, Packet}} + end, Packets). decode_cipher_text(#state{protocol_buffers = #protocol_buffers{dtls_cipher_texts = [ CT | Rest]} = Buffers, connection_states = ConnStates0} = State) -> @@ -897,6 +800,178 @@ dtls_version(hello, Version, #state{role = server} = State) -> dtls_version(_,_, State) -> State. +handle_client_hello(#client_hello{client_version = ClientVersion} = Hello, + #state{connection_states = ConnectionStates0, + port = Port, session = #session{own_certificate = Cert} = Session0, + renegotiation = {Renegotiation, _}, + session_cache = Cache, + session_cache_cb = CacheCb, + negotiated_protocol = CurrentProtocol, + key_algorithm = KeyExAlg, + ssl_options = SslOpts} = State0) -> + + case dtls_handshake:hello(Hello, SslOpts, {Port, Session0, Cache, CacheCb, + ConnectionStates0, Cert, KeyExAlg}, Renegotiation) of + #alert{} = Alert -> + handle_own_alert(Alert, ClientVersion, hello, State0); + {Version, {Type, Session}, + ConnectionStates, Protocol0, ServerHelloExt, HashSign} -> + Protocol = case Protocol0 of + undefined -> CurrentProtocol; + _ -> Protocol0 + end, + + State = prepare_flight(State0#state{connection_states = ConnectionStates, + negotiated_version = Version, + hashsign_algorithm = HashSign, + client_hello_version = ClientVersion, + session = Session, + negotiated_protocol = Protocol}), + + ssl_connection:hello(internal, {common_client_hello, Type, ServerHelloExt}, + State, ?MODULE) + end. + + +%% raw data from socket, unpack records +handle_info({Protocol, _, _, _, Data}, StateName, + #state{data_tag = Protocol} = State0) -> + case next_dtls_record(Data, StateName, State0) of + {Record, State} -> + next_event(StateName, Record, State); + #alert{} = Alert -> + ssl_connection:handle_normal_shutdown(Alert, StateName, State0), + ssl_connection:stop({shutdown, own_alert}, State0) + end; +handle_info({CloseTag, Socket}, StateName, + #state{socket = Socket, + socket_options = #socket_options{active = Active}, + protocol_buffers = #protocol_buffers{dtls_cipher_texts = CTs}, + close_tag = CloseTag, + negotiated_version = Version} = State) -> + %% Note that as of DTLS 1.2 (TLS 1.1), + %% failure to properly close a connection no longer requires that a + %% session not be resumed. This is a change from DTLS 1.0 to conform + %% with widespread implementation practice. + case (Active == false) andalso (CTs =/= []) of + false -> + case Version of + {254, N} when N =< 253 -> + ok; + _ -> + %% As invalidate_sessions here causes performance issues, + %% we will conform to the widespread implementation + %% practice and go aginst the spec + %%invalidate_session(Role, Host, Port, Session) + ok + end, + ssl_connection:handle_normal_shutdown(?ALERT_REC(?FATAL, ?CLOSE_NOTIFY), StateName, State), + ssl_connection:stop({shutdown, transport_closed}, State); + true -> + %% Fixes non-delivery of final DTLS record in {active, once}. + %% Basically allows the application the opportunity to set {active, once} again + %% and then receive the final message. + next_event(StateName, no_record, State) + end; + +handle_info(new_cookie_secret, StateName, + #state{protocol_specific = #{current_cookie_secret := Secret} = CookieInfo} = State) -> + erlang:send_after(dtls_v1:cookie_timeout(), self(), new_cookie_secret), + {next_state, StateName, State#state{protocol_specific = + CookieInfo#{current_cookie_secret => dtls_v1:cookie_secret(), + previous_cookie_secret => Secret}}}; +handle_info(Msg, StateName, State) -> + ssl_connection:StateName(info, Msg, State, ?MODULE). + +handle_state_timeout(flight_retransmission_timeout, StateName, + #state{flight_state = {retransmit, NextTimeout}} = State0) -> + {State1, Actions0} = send_handshake_flight(State0#state{flight_state = {retransmit, NextTimeout}}, + retransmit_epoch(StateName, State0)), + {Record, State2} = next_record(State1), + {next_state, StateName, State, Actions} = next_event(StateName, Record, State2, Actions0), + %% This will reset the retransmission timer by repeating the enter state event + {repeat_state, State, Actions}. + +handle_alerts([], Result) -> + Result; +handle_alerts(_, {stop, _, _} = Stop) -> + Stop; +handle_alerts([Alert | Alerts], {next_state, StateName, State}) -> + handle_alerts(Alerts, ssl_connection:handle_alert(Alert, StateName, State)); +handle_alerts([Alert | Alerts], {next_state, StateName, State, _Actions}) -> + handle_alerts(Alerts, ssl_connection:handle_alert(Alert, StateName, State)). + +handle_own_alert(Alert, Version, StateName, #state{transport_cb = gen_udp, + role = Role, + ssl_options = Options} = State0) -> + case ignore_alert(Alert, State0) of + {true, State} -> + log_ignore_alert(Options#ssl_options.log_alert, StateName, Alert, Role), + {next_state, StateName, State}; + {false, State} -> + ssl_connection:handle_own_alert(Alert, Version, StateName, State) + end; +handle_own_alert(Alert, Version, StateName, State) -> + ssl_connection:handle_own_alert(Alert, Version, StateName, State). + +encode_handshake_flight(Flight, Version, MaxFragmentSize, Epoch, ConnectionStates) -> + Fragments = lists:map(fun(Handshake) -> + dtls_handshake:fragment_handshake(Handshake, MaxFragmentSize) + end, Flight), + dtls_record:encode_handshake(Fragments, Version, Epoch, ConnectionStates). + +encode_change_cipher(#change_cipher_spec{}, Version, Epoch, ConnectionStates) -> + dtls_record:encode_change_cipher_spec(Version, Epoch, ConnectionStates). + +decode_alerts(Bin) -> + ssl_alert:decode(Bin). + +gen_handshake(StateName, Type, Event, + #state{negotiated_version = Version} = State) -> + try ssl_connection:StateName(Type, Event, State, ?MODULE) of + Result -> + Result + catch + _:_ -> + ssl_connection:handle_own_alert(?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, + malformed_handshake_data), + Version, StateName, State) + end. + +gen_info(Event, connection = StateName, #state{negotiated_version = Version} = State) -> + try handle_info(Event, StateName, State) of + Result -> + Result + catch + _:_ -> + ssl_connection:handle_own_alert(?ALERT_REC(?FATAL, ?INTERNAL_ERROR, + malformed_data), + Version, StateName, State) + end; + +gen_info(Event, StateName, #state{negotiated_version = Version} = State) -> + try handle_info(Event, StateName, State) of + Result -> + Result + catch + _:_ -> + ssl_connection:handle_own_alert(?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, + malformed_handshake_data), + Version, StateName, State) + end. +unprocessed_events(Events) -> + %% The first handshake event will be processed immediately + %% as it is entered first in the event queue and + %% when it is processed there will be length(Events)-1 + %% handshake events left to process before we should + %% process more TLS-records received on the socket. + erlang:length(Events)-1. + +update_handshake_history(#hello_verify_request{}, _, Hist) -> + Hist; +update_handshake_history(_, Handshake, Hist) -> + %% DTLS never needs option "v2_hello_compatible" to be true + ssl_handshake:update_handshake_history(Hist, iolist_to_binary(Handshake), false). prepare_flight(#state{flight_buffer = Flight, connection_states = ConnectionStates0, protocol_buffers = @@ -937,67 +1012,67 @@ new_timeout(N) when N =< 30 -> new_timeout(_) -> 60. -dtls_handshake_events(Packets) -> - lists:map(fun(Packet) -> - {next_event, internal, {handshake, Packet}} - end, Packets). +send_handshake_flight(#state{socket = Socket, + transport_cb = Transport, + flight_buffer = #{handshakes := Flight, + change_cipher_spec := undefined}, + negotiated_version = Version, + connection_states = ConnectionStates0} = State0, Epoch) -> + %% TODO remove hardcoded Max size + {Encoded, ConnectionStates} = + encode_handshake_flight(lists:reverse(Flight), Version, 1400, Epoch, ConnectionStates0), + send(Transport, Socket, Encoded), + {State0#state{connection_states = ConnectionStates}, []}; -renegotiate(#state{role = client} = State, Actions) -> - %% Handle same way as if server requested - %% the renegotiation - %% Hs0 = ssl_handshake:init_handshake_history(), - {next_state, connection, State, - [{next_event, internal, #hello_request{}} | Actions]}; +send_handshake_flight(#state{socket = Socket, + transport_cb = Transport, + flight_buffer = #{handshakes := [_|_] = Flight0, + change_cipher_spec := ChangeCipher, + handshakes_after_change_cipher_spec := []}, + negotiated_version = Version, + connection_states = ConnectionStates0} = State0, Epoch) -> + {HsBefore, ConnectionStates1} = + encode_handshake_flight(lists:reverse(Flight0), Version, 1400, Epoch, ConnectionStates0), + {EncChangeCipher, ConnectionStates} = encode_change_cipher(ChangeCipher, Version, Epoch, ConnectionStates1), -renegotiate(#state{role = server} = State0, Actions) -> - HelloRequest = ssl_handshake:hello_request(), - State1 = prepare_flight(State0), - {State2, MoreActions} = send_handshake(HelloRequest, State1), - {Record, State} = next_record(State2), - next_event(hello, Record, State, Actions ++ MoreActions). + send(Transport, Socket, [HsBefore, EncChangeCipher]), + {State0#state{connection_states = ConnectionStates}, []}; -handle_alerts([], Result) -> - Result; -handle_alerts(_, {stop,_} = Stop) -> - Stop; -handle_alerts([Alert | Alerts], {next_state, StateName, State}) -> - handle_alerts(Alerts, ssl_connection:handle_alert(Alert, StateName, State)); -handle_alerts([Alert | Alerts], {next_state, StateName, State, _Actions}) -> - handle_alerts(Alerts, ssl_connection:handle_alert(Alert, StateName, State)). +send_handshake_flight(#state{socket = Socket, + transport_cb = Transport, + flight_buffer = #{handshakes := [_|_] = Flight0, + change_cipher_spec := ChangeCipher, + handshakes_after_change_cipher_spec := Flight1}, + negotiated_version = Version, + connection_states = ConnectionStates0} = State0, Epoch) -> + {HsBefore, ConnectionStates1} = + encode_handshake_flight(lists:reverse(Flight0), Version, 1400, Epoch-1, ConnectionStates0), + {EncChangeCipher, ConnectionStates2} = + encode_change_cipher(ChangeCipher, Version, Epoch-1, ConnectionStates1), + {HsAfter, ConnectionStates} = + encode_handshake_flight(lists:reverse(Flight1), Version, 1400, Epoch, ConnectionStates2), + send(Transport, Socket, [HsBefore, EncChangeCipher, HsAfter]), + {State0#state{connection_states = ConnectionStates}, []}; + +send_handshake_flight(#state{socket = Socket, + transport_cb = Transport, + flight_buffer = #{handshakes := [], + change_cipher_spec := ChangeCipher, + handshakes_after_change_cipher_spec := Flight1}, + negotiated_version = Version, + connection_states = ConnectionStates0} = State0, Epoch) -> + {EncChangeCipher, ConnectionStates1} = + encode_change_cipher(ChangeCipher, Version, Epoch-1, ConnectionStates0), + {HsAfter, ConnectionStates} = + encode_handshake_flight(lists:reverse(Flight1), Version, 1400, Epoch, ConnectionStates1), + send(Transport, Socket, [EncChangeCipher, HsAfter]), + {State0#state{connection_states = ConnectionStates}, []}. retransmit_epoch(_StateName, #state{connection_states = ConnectionStates}) -> #{epoch := Epoch} = ssl_record:current_connection_state(ConnectionStates, write), Epoch. -update_handshake_history(#hello_verify_request{}, _, Hist) -> - Hist; -update_handshake_history(_, Handshake, Hist) -> - %% DTLS never needs option "v2_hello_compatible" to be true - ssl_handshake:update_handshake_history(Hist, iolist_to_binary(Handshake), false). - -unprocessed_events(Events) -> - %% The first handshake event will be processed immediately - %% as it is entered first in the event queue and - %% when it is processed there will be length(Events)-1 - %% handshake events left to process before we should - %% process more TLS-records received on the socket. - erlang:length(Events)-1. - -handle_own_alert(Alert, Version, StateName, #state{transport_cb = gen_udp, - role = Role, - ssl_options = Options} = State0) -> - case ignore_alert(Alert, State0) of - {true, State} -> - log_ignore_alert(Options#ssl_options.log_alert, StateName, Alert, Role), - {next_state, StateName, State}; - {false, State} -> - ssl_connection:handle_own_alert(Alert, Version, StateName, State) - end; -handle_own_alert(Alert, Version, StateName, State) -> - ssl_connection:handle_own_alert(Alert, Version, StateName, State). - - ignore_alert(#alert{level = ?FATAL}, #state{protocol_specific = #{ignored_alerts := N, max_ignored_alerts := N}} = State) -> {false, State}; diff --git a/lib/ssl/src/dtls_handshake.erl b/lib/ssl/src/dtls_handshake.erl index 37a46b862e..6071eece13 100644 --- a/lib/ssl/src/dtls_handshake.erl +++ b/lib/ssl/src/dtls_handshake.erl @@ -16,6 +16,11 @@ %% limitations under the License. %% %% %CopyrightEnd% + +%%---------------------------------------------------------------------- +%% Purpose: Help funtions for handling the DTLS (specific parts of) +%%% SSL/TLS/DTLS handshake protocol +%%---------------------------------------------------------------------- -module(dtls_handshake). -include("dtls_connection.hrl"). @@ -24,15 +29,21 @@ -include("ssl_internal.hrl"). -include("ssl_alert.hrl"). +%% Handshake handling -export([client_hello/8, client_hello/9, cookie/4, hello/4, - hello_verify_request/2, get_dtls_handshake/3, fragment_handshake/2, - handshake_bin/2, encode_handshake/3]). + hello_verify_request/2]). + +%% Handshake encoding +-export([fragment_handshake/2, encode_handshake/3]). + +%% Handshake decodeing +-export([get_dtls_handshake/3]). -type dtls_handshake() :: #client_hello{} | #hello_verify_request{} | ssl_handshake:ssl_handshake(). %%==================================================================== -%% Internal application API +%% Handshake handling %%==================================================================== %%-------------------------------------------------------------------- -spec client_hello(host(), inet:port_number(), ssl_record:connection_states(), @@ -56,7 +67,8 @@ client_hello(Host, Port, ConnectionStates, SslOpts, %%-------------------------------------------------------------------- client_hello(Host, Port, Cookie, ConnectionStates, #ssl_options{versions = Versions, - ciphers = UserSuites + ciphers = UserSuites, + fallback = Fallback } = SslOpts, Cache, CacheCb, Renegotiation, OwnCert) -> Version = dtls_record:highest_protocol_version(Versions), @@ -66,12 +78,15 @@ client_hello(Host, Port, Cookie, ConnectionStates, CipherSuites = ssl_handshake:available_suites(UserSuites, TLSVersion), Extensions = ssl_handshake:client_hello_extensions(TLSVersion, CipherSuites, - SslOpts, ConnectionStates, Renegotiation), + SslOpts, ConnectionStates, + Renegotiation), Id = ssl_session:client_id({Host, Port, SslOpts}, Cache, CacheCb, OwnCert), #client_hello{session_id = Id, client_version = Version, - cipher_suites = ssl_handshake:cipher_suites(CipherSuites, Renegotiation), + cipher_suites = + ssl_handshake:cipher_suites(CipherSuites, + Renegotiation, Fallback), compression_methods = ssl_record:compressions(), random = SecParams#security_parameters.client_random, cookie = Cookie, @@ -87,11 +102,11 @@ hello(#server_hello{server_version = Version, random = Random, case dtls_record:is_acceptable_version(Version, SupportedVersions) of true -> handle_server_hello_extensions(Version, SessionId, Random, CipherSuite, - Compression, HelloExt, SslOpt, ConnectionStates0, Renegotiation); + Compression, HelloExt, SslOpt, + ConnectionStates0, Renegotiation); false -> ?ALERT_REC(?FATAL, ?PROTOCOL_VERSION) end; - hello(#client_hello{client_version = ClientVersion} = Hello, #ssl_options{versions = Versions} = SslOpts, Info, Renegotiation) -> @@ -107,7 +122,7 @@ cookie(Key, Address, Port, #client_hello{client_version = {Major, Minor}, <<?BYTE(Major), ?BYTE(Minor)>>, Random, SessionId, CipherSuites, CompressionMethods], crypto:hmac(sha, Key, CookieData). - +%%-------------------------------------------------------------------- -spec hello_verify_request(binary(), dtls_record:dtls_version()) -> #hello_verify_request{}. %% %% Description: Creates a hello verify request message sent by server to @@ -117,11 +132,8 @@ hello_verify_request(Cookie, Version) -> #hello_verify_request{protocol_version = Version, cookie = Cookie}. %%-------------------------------------------------------------------- - -encode_handshake(Handshake, Version, Seq) -> - {MsgType, Bin} = enc_handshake(Handshake, Version), - Len = byte_size(Bin), - [MsgType, ?uint24(Len), ?uint16(Seq), ?uint24(0), ?uint24(Len), Bin]. +%%% Handshake encoding +%%-------------------------------------------------------------------- fragment_handshake(Bin, _) when is_binary(Bin)-> %% This is the change_cipher_spec not a "real handshake" but part of the flight @@ -129,10 +141,15 @@ fragment_handshake(Bin, _) when is_binary(Bin)-> fragment_handshake([MsgType, Len, Seq, _, Len, Bin], Size) -> Bins = bin_fragments(Bin, Size), handshake_fragments(MsgType, Seq, Len, Bins, []). +encode_handshake(Handshake, Version, Seq) -> + {MsgType, Bin} = enc_handshake(Handshake, Version), + Len = byte_size(Bin), + [MsgType, ?uint24(Len), ?uint16(Seq), ?uint24(0), ?uint24(Len), Bin]. + +%%-------------------------------------------------------------------- +%%% Handshake decodeing +%%-------------------------------------------------------------------- -handshake_bin([Type, Length, Data], Seq) -> - handshake_bin(Type, Length, Seq, Data). - %%-------------------------------------------------------------------- -spec get_dtls_handshake(dtls_record:dtls_version(), binary(), #protocol_buffers{}) -> {[dtls_handshake()], #protocol_buffers{}}. @@ -147,16 +164,19 @@ get_dtls_handshake(Version, Fragment, ProtocolBuffers) -> %%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- -handle_client_hello(Version, #client_hello{session_id = SugesstedId, - cipher_suites = CipherSuites, - compression_methods = Compressions, - random = Random, - extensions = - #hello_extensions{elliptic_curves = Curves, - signature_algs = ClientHashSigns} = HelloExt}, +handle_client_hello(Version, + #client_hello{session_id = SugesstedId, + cipher_suites = CipherSuites, + compression_methods = Compressions, + random = Random, + extensions = + #hello_extensions{elliptic_curves = Curves, + signature_algs = ClientHashSigns} + = HelloExt}, #ssl_options{versions = Versions, signature_algs = SupportedHashSigns} = SslOpts, - {Port, Session0, Cache, CacheCb, ConnectionStates0, Cert, _}, Renegotiation) -> + {Port, Session0, Cache, CacheCb, ConnectionStates0, Cert, _}, + Renegotiation) -> case dtls_record:is_acceptable_version(Version, Versions) of true -> TLSVersion = dtls_v1:corresponding_tls_version(Version), @@ -164,14 +184,15 @@ handle_client_hello(Version, #client_hello{session_id = SugesstedId, ClientHashSigns, SupportedHashSigns, Cert,TLSVersion), ECCCurve = ssl_handshake:select_curve(Curves, ssl_handshake:supported_ecc(TLSVersion)), {Type, #session{cipher_suite = CipherSuite} = Session1} - = ssl_handshake:select_session(SugesstedId, CipherSuites, AvailableHashSigns, Compressions, + = ssl_handshake:select_session(SugesstedId, CipherSuites, + AvailableHashSigns, Compressions, Port, Session0#session{ecc = ECCCurve}, TLSVersion, SslOpts, Cache, CacheCb, Cert), case CipherSuite of no_suite -> ?ALERT_REC(?FATAL, ?INSUFFICIENT_SECURITY); _ -> - {KeyExAlg,_,_,_} = ssl_cipher:suite_definition(CipherSuite), + #{key_exchange := KeyExAlg} = ssl_cipher:suite_definition(CipherSuite), case ssl_handshake:select_hashsign(ClientHashSigns, Cert, KeyExAlg, SupportedHashSigns, TLSVersion) of #alert{} = Alert -> @@ -190,7 +211,8 @@ handle_client_hello_extensions(Version, Type, Random, CipherSuites, HelloExt, SslOpts, Session0, ConnectionStates0, Renegotiation, HashSign) -> try ssl_handshake:handle_client_hello_extensions(dtls_record, Random, CipherSuites, HelloExt, dtls_v1:corresponding_tls_version(Version), - SslOpts, Session0, ConnectionStates0, Renegotiation) of + SslOpts, Session0, + ConnectionStates0, Renegotiation) of #alert{} = Alert -> Alert; {Session, ConnectionStates, Protocol, ServerHelloExt} -> @@ -212,7 +234,7 @@ handle_server_hello_extensions(Version, SessionId, Random, CipherSuite, end. -%%%%%%% Encodeing %%%%%%%%%%%%% +%%-------------------------------------------------------------------- enc_handshake(#hello_verify_request{protocol_version = {Major, Minor}, cookie = Cookie}, _Version) -> @@ -220,7 +242,6 @@ enc_handshake(#hello_verify_request{protocol_version = {Major, Minor}, {?HELLO_VERIFY_REQUEST, <<?BYTE(Major), ?BYTE(Minor), ?BYTE(CookieLength), Cookie:CookieLength/binary>>}; - enc_handshake(#hello_request{}, _Version) -> {?HELLO_REQUEST, <<>>}; enc_handshake(#client_hello{client_version = {Major, Minor}, @@ -243,19 +264,29 @@ enc_handshake(#client_hello{client_version = {Major, Minor}, ?BYTE(CookieLength), Cookie/binary, ?UINT16(CsLength), BinCipherSuites/binary, ?BYTE(CmLength), BinCompMethods/binary, ExtensionsBin/binary>>}; - enc_handshake(#server_hello{} = HandshakeMsg, Version) -> {Type, <<?BYTE(Major), ?BYTE(Minor), Rest/binary>>} = ssl_handshake:encode_handshake(HandshakeMsg, Version), {DTLSMajor, DTLSMinor} = dtls_v1:corresponding_dtls_version({Major, Minor}), {Type, <<?BYTE(DTLSMajor), ?BYTE(DTLSMinor), Rest/binary>>}; - enc_handshake(HandshakeMsg, Version) -> ssl_handshake:encode_handshake(HandshakeMsg, dtls_v1:corresponding_tls_version(Version)). +handshake_bin(#handshake_fragment{ + type = Type, + length = Len, + message_seq = Seq, + fragment_length = Len, + fragment_offset = 0, + fragment = Fragment}) -> + handshake_bin(Type, Len, Seq, Fragment). +handshake_bin(Type, Length, Seq, FragmentData) -> + <<?BYTE(Type), ?UINT24(Length), + ?UINT16(Seq), ?UINT24(0), ?UINT24(Length), + FragmentData:Length/binary>>. + bin_fragments(Bin, Size) -> bin_fragments(Bin, size(Bin), Size, 0, []). - bin_fragments(Bin, BinSize, FragSize, Offset, Fragments) -> case (BinSize - Offset - FragSize) > 0 of true -> @@ -279,7 +310,7 @@ address_to_bin({A,B,C,D}, Port) -> address_to_bin({A,B,C,D,E,F,G,H}, Port) -> <<A:16,B:16,C:16,D:16,E:16,F:16,G:16,H:16,Port:16>>. -%%%%%%% Decodeing %%%%%%%%%%%%% +%%-------------------------------------------------------------------- handle_fragments(Version, FragmentData, Buffers0, Acc) -> Fragments = decode_handshake_fragments(FragmentData), @@ -322,7 +353,6 @@ decode_handshake(_Version, ?CLIENT_HELLO, <<?UINT24(_), ?UINT16(_), compression_methods = Comp_methods, extensions = DecodedExtensions }; - decode_handshake(_Version, ?HELLO_VERIFY_REQUEST, <<?UINT24(_), ?UINT16(_), ?UINT24(_), ?UINT24(_), ?BYTE(Major), ?BYTE(Minor), @@ -330,7 +360,6 @@ decode_handshake(_Version, ?HELLO_VERIFY_REQUEST, <<?UINT24(_), ?UINT16(_), Cookie:CookieLength/binary>>) -> #hello_verify_request{protocol_version = {Major, Minor}, cookie = Cookie}; - decode_handshake(Version, Tag, <<?UINT24(_), ?UINT16(_), ?UINT24(_), ?UINT24(_), Msg/binary>>) -> %% DTLS specifics stripped @@ -370,9 +399,10 @@ reassemble(Version, #handshake_fragment{message_seq = Seq} = Fragment, end; reassemble(_, #handshake_fragment{message_seq = FragSeq} = Fragment, #protocol_buffers{dtls_handshake_next_seq = Seq, - dtls_handshake_later_fragments = LaterFragments} = Buffers0) when FragSeq > Seq-> - {more_data, - Buffers0#protocol_buffers{dtls_handshake_later_fragments = [Fragment | LaterFragments]}}; + dtls_handshake_later_fragments = LaterFragments} + = Buffers0) when FragSeq > Seq-> + {more_data, + Buffers0#protocol_buffers{dtls_handshake_later_fragments = [Fragment | LaterFragments]}}; reassemble(_, _, Buffers) -> %% Disregard fragments FragSeq < Seq {more_data, Buffers}. @@ -396,26 +426,6 @@ merge_fragment(Frag0, [Frag1 | Rest]) -> Frag -> merge_fragment(Frag, Rest) end. - -is_complete_handshake(#handshake_fragment{length = Length, fragment_length = Length}) -> - true; -is_complete_handshake(_) -> - false. - -next_fragments(LaterFragments) -> - case lists:keysort(#handshake_fragment.message_seq, LaterFragments) of - [] -> - {[], []}; - [#handshake_fragment{message_seq = Seq} | _] = Fragments -> - split_frags(Fragments, Seq, []) - end. - -split_frags([#handshake_fragment{message_seq = Seq} = Frag | Rest], Seq, Acc) -> - split_frags(Rest, Seq, [Frag | Acc]); -split_frags(Frags, _, Acc) -> - {lists:reverse(Acc), Frags}. - - %% Duplicate merge_fragments(#handshake_fragment{ fragment_offset = PreviousOffSet, @@ -486,17 +496,26 @@ merge_fragments(#handshake_fragment{ %% No merge there is a gap merge_fragments(Previous, Current) -> [Previous, Current]. - -handshake_bin(#handshake_fragment{ - type = Type, - length = Len, - message_seq = Seq, - fragment_length = Len, - fragment_offset = 0, - fragment = Fragment}) -> - handshake_bin(Type, Len, Seq, Fragment). -handshake_bin(Type, Length, Seq, FragmentData) -> - <<?BYTE(Type), ?UINT24(Length), - ?UINT16(Seq), ?UINT24(0), ?UINT24(Length), - FragmentData:Length/binary>>. +next_fragments(LaterFragments) -> + case lists:keysort(#handshake_fragment.message_seq, LaterFragments) of + [] -> + {[], []}; + [#handshake_fragment{message_seq = Seq} | _] = Fragments -> + split_frags(Fragments, Seq, []) + end. + +split_frags([#handshake_fragment{message_seq = Seq} = Frag | Rest], Seq, Acc) -> + split_frags(Rest, Seq, [Frag | Acc]); +split_frags(Frags, _, Acc) -> + {lists:reverse(Acc), Frags}. + +is_complete_handshake(#handshake_fragment{length = Length, fragment_length = Length}) -> + true; +is_complete_handshake(_) -> + false. + + + + + diff --git a/lib/ssl/src/dtls_record.erl b/lib/ssl/src/dtls_record.erl index a8520717e5..316de05532 100644 --- a/lib/ssl/src/dtls_record.erl +++ b/lib/ssl/src/dtls_record.erl @@ -30,15 +30,17 @@ -include("ssl_cipher.hrl"). %% Handling of incoming data --export([get_dtls_records/2, init_connection_states/2, empty_connection_state/1]). +-export([get_dtls_records/3, init_connection_states/2, empty_connection_state/1]). -%% Decoding --export([decode_cipher_text/2]). +-export([save_current_connection_state/2, next_epoch/2, get_connection_state_by_epoch/3, replay_detect/2, + init_connection_state_seq/2, current_connection_state_epoch/2]). %% Encoding -export([encode_handshake/4, encode_alert_record/3, - encode_change_cipher_spec/3, encode_data/3]). --export([encode_plain_text/5]). + encode_change_cipher_spec/3, encode_data/3, encode_plain_text/5]). + +%% Decoding +-export([decode_cipher_text/2]). %% Protocol version handling -export([protocol_version/1, lowest_protocol_version/1, lowest_protocol_version/2, @@ -46,9 +48,6 @@ is_higher/2, supported_protocol_versions/0, is_acceptable_version/2, hello_version/2]). --export([save_current_connection_state/2, next_epoch/2, get_connection_state_by_epoch/3, replay_detect/2]). - --export([init_connection_state_seq/2, current_connection_state_epoch/2]). -export_type([dtls_version/0, dtls_atom_version/0]). @@ -60,7 +59,7 @@ -compile(inline). %%==================================================================== -%% Internal application API +%% Handling of incoming data %%==================================================================== %%-------------------------------------------------------------------- -spec init_connection_states(client | server, one_n_minus_one | zero_n | disabled) -> @@ -86,7 +85,6 @@ init_connection_states(Role, BeastMitigation) -> empty_connection_state(Empty) -> Empty#{epoch => undefined, replay_window => init_replay_window(?REPLAY_WINDOW_SIZE)}. - %%-------------------------------------------------------------------- -spec save_current_connection_state(ssl_record:connection_states(), read | write) -> ssl_record:connection_states(). @@ -137,67 +135,58 @@ set_connection_state_by_epoch(ReadState, Epoch, #{saved_read := #{epoch := Epoch States#{saved_read := ReadState}. %%-------------------------------------------------------------------- --spec get_dtls_records(binary(), binary()) -> {[binary()], binary()} | #alert{}. +-spec init_connection_state_seq(dtls_version(), ssl_record:connection_states()) -> + ssl_record:connection_state(). +%% +%% Description: Copy the read sequence number to the write sequence number +%% This is only valid for DTLS in the first client_hello +%%-------------------------------------------------------------------- +init_connection_state_seq({254, _}, + #{current_read := #{epoch := 0, sequence_number := Seq}, + current_write := #{epoch := 0} = Write} = ConnnectionStates0) -> + ConnnectionStates0#{current_write => Write#{sequence_number => Seq}}; +init_connection_state_seq(_, ConnnectionStates) -> + ConnnectionStates. + +%%-------------------------------------------------------- +-spec current_connection_state_epoch(ssl_record:connection_states(), read | write) -> + integer(). +%% +%% Description: Returns the epoch the connection_state record +%% that is currently defined as the current connection state. +%%-------------------------------------------------------------------- +current_connection_state_epoch(#{current_read := #{epoch := Epoch}}, + read) -> + Epoch; +current_connection_state_epoch(#{current_write := #{epoch := Epoch}}, + write) -> + Epoch. + +%%-------------------------------------------------------------------- +-spec get_dtls_records(binary(), [dtls_version()], binary()) -> {[binary()], binary()} | #alert{}. %% %% Description: Given old buffer and new data from UDP/SCTP, packs up a records %% and returns it as a list of tls_compressed binaries also returns leftover %% data %%-------------------------------------------------------------------- -get_dtls_records(Data, <<>>) -> - get_dtls_records_aux(Data, []); -get_dtls_records(Data, Buffer) -> - get_dtls_records_aux(list_to_binary([Buffer, Data]), []). - -get_dtls_records_aux(<<?BYTE(?APPLICATION_DATA),?BYTE(MajVer),?BYTE(MinVer), - ?UINT16(Epoch), ?UINT48(SequenceNumber), - ?UINT16(Length), Data:Length/binary, Rest/binary>>, - Acc) -> - get_dtls_records_aux(Rest, [#ssl_tls{type = ?APPLICATION_DATA, - version = {MajVer, MinVer}, - epoch = Epoch, sequence_number = SequenceNumber, - fragment = Data} | Acc]); -get_dtls_records_aux(<<?BYTE(?HANDSHAKE),?BYTE(MajVer),?BYTE(MinVer), - ?UINT16(Epoch), ?UINT48(SequenceNumber), - ?UINT16(Length), - Data:Length/binary, Rest/binary>>, Acc) when MajVer >= 128 -> - get_dtls_records_aux(Rest, [#ssl_tls{type = ?HANDSHAKE, - version = {MajVer, MinVer}, - epoch = Epoch, sequence_number = SequenceNumber, - fragment = Data} | Acc]); -get_dtls_records_aux(<<?BYTE(?ALERT),?BYTE(MajVer),?BYTE(MinVer), - ?UINT16(Epoch), ?UINT48(SequenceNumber), - ?UINT16(Length), Data:Length/binary, - Rest/binary>>, Acc) -> - get_dtls_records_aux(Rest, [#ssl_tls{type = ?ALERT, - version = {MajVer, MinVer}, - epoch = Epoch, sequence_number = SequenceNumber, - fragment = Data} | Acc]); -get_dtls_records_aux(<<?BYTE(?CHANGE_CIPHER_SPEC),?BYTE(MajVer),?BYTE(MinVer), - ?UINT16(Epoch), ?UINT48(SequenceNumber), - ?UINT16(Length), Data:Length/binary, Rest/binary>>, - Acc) -> - get_dtls_records_aux(Rest, [#ssl_tls{type = ?CHANGE_CIPHER_SPEC, - version = {MajVer, MinVer}, - epoch = Epoch, sequence_number = SequenceNumber, - fragment = Data} | Acc]); - -get_dtls_records_aux(<<0:1, _CT:7, ?BYTE(_MajVer), ?BYTE(_MinVer), - ?UINT16(Length), _/binary>>, - _Acc) when Length > ?MAX_CIPHER_TEXT_LENGTH -> - ?ALERT_REC(?FATAL, ?RECORD_OVERFLOW); - -get_dtls_records_aux(<<1:1, Length0:15, _/binary>>,_Acc) - when Length0 > ?MAX_CIPHER_TEXT_LENGTH -> - ?ALERT_REC(?FATAL, ?RECORD_OVERFLOW); - -get_dtls_records_aux(Data, Acc) -> - case size(Data) =< ?MAX_CIPHER_TEXT_LENGTH + ?INITIAL_BYTES of - true -> - {lists:reverse(Acc), Data}; - false -> - ?ALERT_REC(?FATAL, ?UNEXPECTED_MESSAGE) +get_dtls_records(Data, Versions, Buffer) -> + BinData = list_to_binary([Buffer, Data]), + case erlang:byte_size(BinData) of + N when N >= 3 -> + case assert_version(BinData, Versions) of + true -> + get_dtls_records_aux(BinData, []); + false -> + ?ALERT_REC(?FATAL, ?BAD_RECORD_MAC) + end; + _ -> + get_dtls_records_aux(BinData, []) end. +%%==================================================================== +%% Encoding DTLS records +%%==================================================================== + %%-------------------------------------------------------------------- -spec encode_handshake(iolist(), dtls_version(), integer(), ssl_record:connection_states()) -> {iolist(), ssl_record:connection_states()}. @@ -245,11 +234,19 @@ encode_plain_text(Type, Version, Epoch, Data, ConnectionStates) -> {CipherText, Write} = encode_dtls_cipher_text(Type, Version, CipherFragment, Write1), {CipherText, set_connection_state_by_epoch(Write, Epoch, ConnectionStates, write)}. +%%==================================================================== +%% Decoding +%%==================================================================== decode_cipher_text(#ssl_tls{epoch = Epoch} = CipherText, ConnnectionStates0) -> ReadState = get_connection_state_by_epoch(Epoch, ConnnectionStates0, read), decode_cipher_text(CipherText, ReadState, ConnnectionStates0). + +%%==================================================================== +%% Protocol version handling +%%==================================================================== + %%-------------------------------------------------------------------- -spec protocol_version(dtls_atom_version() | dtls_version()) -> dtls_version() | dtls_atom_version(). @@ -381,35 +378,6 @@ supported_protocol_versions([_|_] = Vsns) -> is_acceptable_version(Version, Versions) -> lists:member(Version, Versions). - -%%-------------------------------------------------------------------- --spec init_connection_state_seq(dtls_version(), ssl_record:connection_states()) -> - ssl_record:connection_state(). -%% -%% Description: Copy the read sequence number to the write sequence number -%% This is only valid for DTLS in the first client_hello -%%-------------------------------------------------------------------- -init_connection_state_seq({254, _}, - #{current_read := #{epoch := 0, sequence_number := Seq}, - current_write := #{epoch := 0} = Write} = ConnnectionStates0) -> - ConnnectionStates0#{current_write => Write#{sequence_number => Seq}}; -init_connection_state_seq(_, ConnnectionStates) -> - ConnnectionStates. - -%%-------------------------------------------------------- --spec current_connection_state_epoch(ssl_record:connection_states(), read | write) -> - integer(). -%% -%% Description: Returns the epoch the connection_state record -%% that is currently defined as the current connection state. -%%-------------------------------------------------------------------- -current_connection_state_epoch(#{current_read := #{epoch := Epoch}}, - read) -> - Epoch; -current_connection_state_epoch(#{current_write := #{epoch := Epoch}}, - write) -> - Epoch. - -spec hello_version(dtls_version(), [dtls_version()]) -> dtls_version(). hello_version(Version, Versions) -> case dtls_v1:corresponding_tls_version(Version) of @@ -437,16 +405,92 @@ initial_connection_state(ConnectionEnd, BeastMitigation) -> client_verify_data => undefined, server_verify_data => undefined }. +assert_version(<<?BYTE(_), ?BYTE(MajVer), ?BYTE(MinVer), _/binary>>, Versions) -> + is_acceptable_version({MajVer, MinVer}, Versions). -lowest_list_protocol_version(Ver, []) -> - Ver; -lowest_list_protocol_version(Ver1, [Ver2 | Rest]) -> - lowest_list_protocol_version(lowest_protocol_version(Ver1, Ver2), Rest). +get_dtls_records_aux(<<?BYTE(?APPLICATION_DATA),?BYTE(MajVer),?BYTE(MinVer), + ?UINT16(Epoch), ?UINT48(SequenceNumber), + ?UINT16(Length), Data:Length/binary, Rest/binary>>, + Acc) -> + get_dtls_records_aux(Rest, [#ssl_tls{type = ?APPLICATION_DATA, + version = {MajVer, MinVer}, + epoch = Epoch, sequence_number = SequenceNumber, + fragment = Data} | Acc]); +get_dtls_records_aux(<<?BYTE(?HANDSHAKE),?BYTE(MajVer),?BYTE(MinVer), + ?UINT16(Epoch), ?UINT48(SequenceNumber), + ?UINT16(Length), + Data:Length/binary, Rest/binary>>, Acc) when MajVer >= 128 -> + get_dtls_records_aux(Rest, [#ssl_tls{type = ?HANDSHAKE, + version = {MajVer, MinVer}, + epoch = Epoch, sequence_number = SequenceNumber, + fragment = Data} | Acc]); +get_dtls_records_aux(<<?BYTE(?ALERT),?BYTE(MajVer),?BYTE(MinVer), + ?UINT16(Epoch), ?UINT48(SequenceNumber), + ?UINT16(Length), Data:Length/binary, + Rest/binary>>, Acc) -> + get_dtls_records_aux(Rest, [#ssl_tls{type = ?ALERT, + version = {MajVer, MinVer}, + epoch = Epoch, sequence_number = SequenceNumber, + fragment = Data} | Acc]); +get_dtls_records_aux(<<?BYTE(?CHANGE_CIPHER_SPEC),?BYTE(MajVer),?BYTE(MinVer), + ?UINT16(Epoch), ?UINT48(SequenceNumber), + ?UINT16(Length), Data:Length/binary, Rest/binary>>, + Acc) -> + get_dtls_records_aux(Rest, [#ssl_tls{type = ?CHANGE_CIPHER_SPEC, + version = {MajVer, MinVer}, + epoch = Epoch, sequence_number = SequenceNumber, + fragment = Data} | Acc]); -highest_list_protocol_version(Ver, []) -> - Ver; -highest_list_protocol_version(Ver1, [Ver2 | Rest]) -> - highest_list_protocol_version(highest_protocol_version(Ver1, Ver2), Rest). +get_dtls_records_aux(<<?BYTE(_), ?BYTE(_MajVer), ?BYTE(_MinVer), + ?UINT16(Length), _/binary>>, + _Acc) when Length > ?MAX_CIPHER_TEXT_LENGTH -> + ?ALERT_REC(?FATAL, ?RECORD_OVERFLOW); + +get_dtls_records_aux(Data, Acc) -> + case size(Data) =< ?MAX_CIPHER_TEXT_LENGTH + ?INITIAL_BYTES of + true -> + {lists:reverse(Acc), Data}; + false -> + ?ALERT_REC(?FATAL, ?UNEXPECTED_MESSAGE) + end. +%%-------------------------------------------------------------------- + +init_replay_window(Size) -> + #{size => Size, + top => Size, + bottom => 0, + mask => 0 bsl 64 + }. + +replay_detect(#ssl_tls{sequence_number = SequenceNumber}, #{replay_window := Window}) -> + is_replay(SequenceNumber, Window). + + +is_replay(SequenceNumber, #{bottom := Bottom}) when SequenceNumber < Bottom -> + true; +is_replay(SequenceNumber, #{size := Size, + top := Top, + bottom := Bottom, + mask := Mask}) when (SequenceNumber >= Bottom) andalso (SequenceNumber =< Top) -> + Index = (SequenceNumber rem Size), + (Index band Mask) == 1; + +is_replay(_, _) -> + false. + +update_replay_window(SequenceNumber, #{replay_window := #{size := Size, + top := Top, + bottom := Bottom, + mask := Mask0} = Window0} = ConnectionStates) -> + NoNewBits = SequenceNumber - Top, + Index = SequenceNumber rem Size, + Mask = (Mask0 bsl NoNewBits) bor Index, + Window = Window0#{top => SequenceNumber, + bottom => Bottom + NoNewBits, + mask => Mask}, + ConnectionStates#{replay_window := Window}. + +%%-------------------------------------------------------------------- encode_dtls_cipher_text(Type, {MajVer, MinVer}, Fragment, #{epoch := Epoch, sequence_number := Seq} = WriteState) -> @@ -490,6 +534,7 @@ encode_plain_text(Type, Version, Fragment, #{compression_state := CompS0, ssl_cipher:cipher(BulkCipherAlgo, CipherS0, MAC, Fragment, TLSVersion), {CipherFragment, WriteState0#{cipher_state => CipherS1}}. +%%-------------------------------------------------------------------- decode_cipher_text(#ssl_tls{type = Type, version = Version, epoch = Epoch, sequence_number = Seq, @@ -541,6 +586,7 @@ decode_cipher_text(#ssl_tls{type = Type, version = Version, false -> ?ALERT_REC(?FATAL, ?BAD_RECORD_MAC) end. +%%-------------------------------------------------------------------- calc_mac_hash(Type, Version, #{mac_secret := MacSecret, security_parameters := #security_parameters{mac_algorithm = MacAlg}}, @@ -549,16 +595,6 @@ calc_mac_hash(Type, Version, #{mac_secret := MacSecret, mac_hash(Version, MacAlg, MacSecret, Epoch, SeqNo, Type, Length, Fragment). -highest_protocol_version() -> - highest_protocol_version(supported_protocol_versions()). - -lowest_protocol_version() -> - lowest_protocol_version(supported_protocol_versions()). - -sufficient_dtlsv1_2_crypto_support() -> - CryptoSupport = crypto:supports(), - proplists:get_bool(sha256, proplists:get_value(hashs, CryptoSupport)). - mac_hash({Major, Minor}, MacAlg, MacSecret, Epoch, SeqNo, Type, Length, Fragment) -> Value = [<<?UINT16(Epoch), ?UINT48(SeqNo), ?BYTE(Type), ?BYTE(Major), ?BYTE(Minor), ?UINT16(Length)>>, @@ -568,37 +604,25 @@ mac_hash({Major, Minor}, MacAlg, MacSecret, Epoch, SeqNo, Type, Length, Fragment calc_aad(Type, {MajVer, MinVer}, Epoch, SeqNo) -> <<?UINT16(Epoch), ?UINT48(SeqNo), ?BYTE(Type), ?BYTE(MajVer), ?BYTE(MinVer)>>. -init_replay_window(Size) -> - #{size => Size, - top => Size, - bottom => 0, - mask => 0 bsl 64 - }. +%%-------------------------------------------------------------------- -replay_detect(#ssl_tls{sequence_number = SequenceNumber}, #{replay_window := Window}) -> - is_replay(SequenceNumber, Window). +lowest_list_protocol_version(Ver, []) -> + Ver; +lowest_list_protocol_version(Ver1, [Ver2 | Rest]) -> + lowest_list_protocol_version(lowest_protocol_version(Ver1, Ver2), Rest). +highest_list_protocol_version(Ver, []) -> + Ver; +highest_list_protocol_version(Ver1, [Ver2 | Rest]) -> + highest_list_protocol_version(highest_protocol_version(Ver1, Ver2), Rest). -is_replay(SequenceNumber, #{bottom := Bottom}) when SequenceNumber < Bottom -> - true; -is_replay(SequenceNumber, #{size := Size, - top := Top, - bottom := Bottom, - mask := Mask}) when (SequenceNumber >= Bottom) andalso (SequenceNumber =< Top) -> - Index = (SequenceNumber rem Size), - (Index band Mask) == 1; +highest_protocol_version() -> + highest_protocol_version(supported_protocol_versions()). -is_replay(_, _) -> - false. +lowest_protocol_version() -> + lowest_protocol_version(supported_protocol_versions()). + +sufficient_dtlsv1_2_crypto_support() -> + CryptoSupport = crypto:supports(), + proplists:get_bool(sha256, proplists:get_value(hashs, CryptoSupport)). -update_replay_window(SequenceNumber, #{replay_window := #{size := Size, - top := Top, - bottom := Bottom, - mask := Mask0} = Window0} = ConnectionStates) -> - NoNewBits = SequenceNumber - Top, - Index = SequenceNumber rem Size, - Mask = (Mask0 bsl NoNewBits) bor Index, - Window = Window0#{top => SequenceNumber, - bottom => Bottom + NoNewBits, - mask => Mask}, - ConnectionStates#{replay_window := Window}. diff --git a/lib/ssl/src/dtls_udp_listener.erl b/lib/ssl/src/dtls_udp_listener.erl index c9e04767aa..0608c6bd2b 100644 --- a/lib/ssl/src/dtls_udp_listener.erl +++ b/lib/ssl/src/dtls_udp_listener.erl @@ -84,7 +84,7 @@ init([Port, EmOpts, InetOptions, DTLSOptions]) -> listener = Socket, close = false}} catch _:_ -> - {error, closed} + {stop, {shutdown, {error, closed}}} end. handle_call({accept, _}, _, #state{close = true} = State) -> {reply, {error, closed}, State}; @@ -153,15 +153,18 @@ handle_info({udp_error, Socket, Error}, #state{listener = Socket} = State) -> handle_info({'DOWN', _, process, Pid, _}, #state{clients = Clients, dtls_processes = Processes0, + dtls_msq_queues = MsgQueues0, close = ListenClosed} = State) -> Client = kv_get(Pid, Processes0), Processes = kv_delete(Pid, Processes0), + MsgQueues = kv_delete(Client, MsgQueues0), case ListenClosed andalso kv_empty(Processes) of true -> {stop, normal, State}; false -> {noreply, State#state{clients = set_delete(Client, Clients), - dtls_processes = Processes}} + dtls_processes = Processes, + dtls_msq_queues = MsgQueues}} end. terminate(_Reason, _State) -> diff --git a/lib/ssl/src/inet_tls_dist.erl b/lib/ssl/src/inet_tls_dist.erl index 96782dcfc0..8e605bec65 100644 --- a/lib/ssl/src/inet_tls_dist.erl +++ b/lib/ssl/src/inet_tls_dist.erl @@ -324,12 +324,13 @@ do_accept(Driver, Kernel, AcceptPid, DistCtrl, MyNode, Allowed, SetupTime) -> timer = Timer, this_flags = 0, allowed = Allowed}, + link(DistCtrl), dist_util:handshake_other_started(trace(HSData)); {false,IP} -> error_logger:error_msg( "** Connection attempt from " "disallowed IP ~w ** ~n", [IP]), - ?shutdown(trace(no_node)) + ?shutdown2(no_node, trace({disallowed, IP})) end end. @@ -357,7 +358,11 @@ do_setup(Driver, Kernel, Node, Type, MyNode, LongOrShortNames, SetupTime) -> ErlEpmd = net_kernel:epmd_module(), case ErlEpmd:port_please(Name, Ip) of {port, TcpPort, Version} -> - Opts = trace(connect_options(get_ssl_options(client))), + Opts = + trace( + connect_options( + [{server_name_indication, atom_to_list(Node)} + |get_ssl_options(client)])), dist_util:reset_timer(Timer), case ssl:connect( Address, TcpPort, @@ -378,21 +383,26 @@ do_setup(Driver, Kernel, Node, Type, MyNode, LongOrShortNames, SetupTime) -> this_flags = 0, other_version = Version, request_type = Type}, + link(DistCtrl), dist_util:handshake_we_started(trace(HSData)); Other -> %% Other Node may have closed since %% port_please ! ?shutdown2( Node, - trace({shutdown, {connect_failed, Other}})) + trace( + {ssl_connect_failed, Ip, TcpPort, Other})) end; Other -> ?shutdown2( Node, - trace({shutdown, {port_please_failed, Other}})) + trace( + {port_please_failed, ErlEpmd, Name, Ip, Other})) end; Other -> - ?shutdown2(Node, trace({shutdown, {getaddr_failed, Other}})) + ?shutdown2( + Node, + trace({getaddr_failed, Driver, Address, Other})) end. close(Socket) -> @@ -411,8 +421,9 @@ check_ip(Driver, SslSocket) -> case get_ifs(SslSocket) of {ok, IFs, IP} -> check_ip(Driver, IFs, IP); - _ -> - ?shutdown(no_node) + Other -> + ?shutdown2( + no_node, trace({check_ip_failed, SslSocket, Other})) end; _ -> true @@ -441,23 +452,22 @@ get_ifs(#sslsocket{fd = {gen_tcp, Socket, _}}) -> %% If Node is illegal terminate the connection setup!! splitnode(Driver, Node, LongOrShortNames) -> - case split_node(atom_to_list(Node), $@, []) of - [Name|Tail] when Tail =/= [] -> - Host = lists:append(Tail), + case string:split(atom_to_list(Node), "@") of + [Name, Host] when Host =/= [] -> check_node(Driver, Name, Node, Host, LongOrShortNames); [_] -> error_logger:error_msg( "** Nodename ~p illegal, no '@' character **~n", [Node]), - ?shutdown(Node); + ?shutdown2(Node, trace({illegal_node_n@me, Node})); _ -> error_logger:error_msg( "** Nodename ~p illegal **~n", [Node]), - ?shutdown(Node) + ?shutdown2(Node, trace({illegal_node_name, Node})) end. check_node(Driver, Name, Node, Host, LongOrShortNames) -> - case split_node(Host, $., []) of + case string:split(Host, ".") of [_] when LongOrShortNames == longnames -> case Driver:parse_address(Host) of {ok, _} -> @@ -468,35 +478,28 @@ check_node(Driver, Name, Node, Host, LongOrShortNames) -> "fully qualified hostnames **~n" "** Hostname ~s is illegal **~n", [Host]), - ?shutdown(Node) + ?shutdown2(Node, trace({not_longnames, Host})) end; - [_, _ | _] when LongOrShortNames == shortnames -> + [_, _] when LongOrShortNames == shortnames -> error_logger:error_msg( "** System NOT running to use " "fully qualified hostnames **~n" "** Hostname ~s is illegal **~n", [Host]), - ?shutdown(Node); + ?shutdown2(Node, trace({not_shortnames, Host})); _ -> [Name, Host] end. split_node(Node) when is_atom(Node) -> - case split_node(atom_to_list(Node), $@, []) of - [_, Host] -> + case string:split(atom_to_list(Node), "@") of + [Name, Host] when Name =/= [], Host =/= [] -> Host; _ -> false end; split_node(_) -> false. -%% -split_node([Chr|T], Chr, Ack) -> - [lists:reverse(Ack)|split_node(T, Chr, [])]; -split_node([H|T], Chr, Ack) -> - split_node(T, Chr, [H|Ack]); -split_node([], _, Ack) -> - [lists:reverse(Ack)]. %% ------------------------------------------------------------------------- @@ -524,6 +527,17 @@ nodelay() -> get_ssl_options(Type) -> + try ets:lookup(ssl_dist_opts, Type) of + [{Type, Opts}] -> + [{erl_dist, true} | Opts]; + _ -> + get_ssl_dist_arguments(Type) + catch + error:badarg -> + get_ssl_dist_arguments(Type) + end. + +get_ssl_dist_arguments(Type) -> case init:get_argument(ssl_dist_opt) of {ok, Args} -> [{erl_dist, true} | ssl_options(Type, lists:append(Args))]; diff --git a/lib/ssl/src/ssl.app.src b/lib/ssl/src/ssl.app.src index c5b55641a1..3c6cd254c1 100644 --- a/lib/ssl/src/ssl.app.src +++ b/lib/ssl/src/ssl.app.src @@ -63,4 +63,4 @@ {env, []}, {mod, {ssl_app, []}}, {runtime_dependencies, ["stdlib-3.2","public_key-1.5","kernel-6.0", - "erts-10.0","crypto-3.3", "inets-5.10.7"]}]}. + "erts-10.0","crypto-4.2", "inets-5.10.7"]}]}. diff --git a/lib/ssl/src/ssl.erl b/lib/ssl/src/ssl.erl index 60118549e4..a298012f26 100644 --- a/lib/ssl/src/ssl.erl +++ b/lib/ssl/src/ssl.erl @@ -39,7 +39,7 @@ ]). %% SSL/TLS protocol handling --export([cipher_suites/0, cipher_suites/1, eccs/0, eccs/1, versions/0, +-export([cipher_suites/0, cipher_suites/1, cipher_suites/2, eccs/0, eccs/1, versions/0, format_error/1, renegotiate/1, prf/5, negotiated_protocol/1, connection_information/1, connection_information/2]). %% Misc @@ -374,23 +374,40 @@ negotiated_protocol(#sslsocket{pid = Pid}) -> ssl_connection:negotiated_protocol(Pid). %%-------------------------------------------------------------------- --spec cipher_suites() -> [ssl_cipher:erl_cipher_suite()] | [string()]. +-spec cipher_suites() -> [ssl_cipher:old_erl_cipher_suite()] | [string()]. %%-------------------------------------------------------------------- cipher_suites() -> cipher_suites(erlang). %%-------------------------------------------------------------------- --spec cipher_suites(erlang | openssl | all) -> [ssl_cipher:erl_cipher_suite()] | - [string()]. +-spec cipher_suites(erlang | openssl | all) -> [ssl_cipher:old_erl_cipher_suite() | string()]. %% Description: Returns all supported cipher suites. %%-------------------------------------------------------------------- cipher_suites(erlang) -> - [ssl_cipher:erl_suite_definition(Suite) || Suite <- available_suites(default)]; - + Version = tls_record:highest_protocol_version([]), + cipher_suites(erlang, Version); cipher_suites(openssl) -> - [ssl_cipher:openssl_suite_name(Suite) || Suite <- available_suites(default)]; - + Version = tls_record:highest_protocol_version([]), + cipher_suites(openssl, Version); cipher_suites(all) -> - [ssl_cipher:erl_suite_definition(Suite) || Suite <- available_suites(all)]. + Version = tls_record:highest_protocol_version([]), + cipher_suites(all, Version). + +%%-------------------------------------------------------------------- +-spec cipher_suites(erlang | openssl | all, tls_record:tls_version() | + dtls_record:dtls_version()) -> [ssl_cipher:old_erl_cipher_suite() | string()]. +%% Description: Returns all supported cipher suites. +%%-------------------------------------------------------------------- +cipher_suites(Type, Version) when Version == 'dtlsv1'; + Version == 'dtlsv1.2' -> + cipher_suites(Type, dtls_record:protocol_version(Version)); +cipher_suites(Type, Version) when is_atom(Version) -> + cipher_suites(Type, tls_record:protocol_version(Version)); +cipher_suites(erlang, Version) -> + [ssl_cipher:erl_suite_definition(Suite) || Suite <- available_suites(default, Version)]; +cipher_suites(openssl, Version) -> + [ssl_cipher:openssl_suite_name(Suite) || Suite <- available_suites(default, Version)]; +cipher_suites(all, Version) -> + [ssl_cipher:erl_suite_definition(Suite) || Suite <- available_suites(all, Version)]. %%-------------------------------------------------------------------- -spec eccs() -> tls_v1:curves(). @@ -411,6 +428,11 @@ eccs({3,0}) -> eccs({3,_}) -> Curves = tls_v1:ecc_curves(all), eccs_filter_supported(Curves); +eccs({_,_} = DTLSVersion) -> + eccs(dtls_v1:corresponding_tls_version(DTLSVersion)); +eccs(DTLSAtomVersion) when DTLSAtomVersion == 'dtlsv1'; + DTLSAtomVersion == 'dtlsv2' -> + eccs(dtls_record:protocol_version(DTLSAtomVersion)); eccs(AtomVersion) when is_atom(AtomVersion) -> eccs(tls_record:protocol_version(AtomVersion)). @@ -543,16 +565,23 @@ sockname(#sslsocket{pid = Pid, fd = {Transport, Socket, _, _}}) when is_pid(Pid) %%--------------------------------------------------------------- -spec versions() -> [{ssl_app, string()} | {supported, [tls_record:tls_atom_version()]} | - {available, [tls_record:tls_atom_version()]}]. + {supported_dtls, [dtls_record:dtls_atom_version()]} | + {available, [tls_record:tls_atom_version()]} | + {available_dtls, [dtls_record:dtls_atom_version()]}]. %% %% Description: Returns a list of relevant versions. %%-------------------------------------------------------------------- versions() -> - Vsns = tls_record:supported_protocol_versions(), - SupportedVsns = [tls_record:protocol_version(Vsn) || Vsn <- Vsns], - AvailableVsns = ?ALL_AVAILABLE_VERSIONS, - %% TODO Add DTLS versions when supported - [{ssl_app, ?VSN}, {supported, SupportedVsns}, {available, AvailableVsns}]. + TLSVsns = tls_record:supported_protocol_versions(), + DTLSVsns = dtls_record:supported_protocol_versions(), + SupportedTLSVsns = [tls_record:protocol_version(Vsn) || Vsn <- TLSVsns], + SupportedDTLSVsns = [dtls_record:protocol_version(Vsn) || Vsn <- DTLSVsns], + AvailableTLSVsns = ?ALL_AVAILABLE_VERSIONS, + AvailableDTLSVsns = ?ALL_AVAILABLE_DATAGRAM_VERSIONS, + [{ssl_app, ?VSN}, {supported, SupportedTLSVsns}, + {supported_dtls, SupportedDTLSVsns}, + {available, AvailableTLSVsns}, + {available_dtls, AvailableDTLSVsns}]. %%--------------------------------------------------------------- @@ -634,12 +663,10 @@ tls_version({254, _} = Version) -> %%%-------------------------------------------------------------------- %% Possible filters out suites not supported by crypto -available_suites(default) -> - Version = tls_record:highest_protocol_version([]), +available_suites(default, Version) -> ssl_cipher:filter_suites(ssl_cipher:suites(Version)); -available_suites(all) -> - Version = tls_record:highest_protocol_version([]), +available_suites(all, Version) -> ssl_cipher:filter_suites(ssl_cipher:all_suites(Version)). do_listen(Port, #config{transport_info = {Transport, _, _, _}} = Config, tls_connection) -> @@ -896,7 +923,8 @@ validate_option(key, {KeyType, Value}) when is_binary(Value), KeyType == 'ECPrivateKey'; KeyType == 'PrivateKeyInfo' -> {KeyType, Value}; - +validate_option(key, #{algorithm := _} = Value) -> + Value; validate_option(keyfile, undefined) -> <<>>; validate_option(keyfile, Value) when is_binary(Value) -> @@ -991,17 +1019,21 @@ validate_option(next_protocols_advertised, Value) when is_list(Value) -> Value; validate_option(next_protocols_advertised, undefined) -> undefined; -validate_option(server_name_indication = Opt, Value) when is_list(Value) -> +validate_option(server_name_indication, Value) when is_list(Value) -> %% RFC 6066, Section 3: Currently, the only server names supported are %% DNS hostnames - case inet_parse:domain(Value) of - false -> - throw({error, {options, {{Opt, Value}}}}); - true -> - Value - end; -validate_option(server_name_indication, undefined = Value) -> + %% case inet_parse:domain(Value) of + %% false -> + %% throw({error, {options, {{Opt, Value}}}}); + %% true -> + %% Value + %% end; + %% + %% But the definition seems very diffuse, so let all strings through + %% and leave it up to public_key to decide... Value; +validate_option(server_name_indication, undefined) -> + undefined; validate_option(server_name_indication, disable) -> disable; @@ -1148,9 +1180,8 @@ binary_cipher_suites(Version, []) -> %% not require explicit configuration ssl_cipher:filter_suites(ssl_cipher:suites(tls_version(Version))); binary_cipher_suites(Version, [Tuple|_] = Ciphers0) when is_tuple(Tuple) -> - Ciphers = [ssl_cipher:suite(C) || C <- Ciphers0], + Ciphers = [ssl_cipher:suite(tuple_to_map(C)) || C <- Ciphers0], binary_cipher_suites(Version, Ciphers); - binary_cipher_suites(Version, [Cipher0 | _] = Ciphers0) when is_binary(Cipher0) -> All = ssl_cipher:all_suites(tls_version(Version)), case [Cipher || Cipher <- Ciphers0, lists:member(Cipher, All)] of @@ -1170,6 +1201,17 @@ binary_cipher_suites(Version, Ciphers0) -> Ciphers = [ssl_cipher:openssl_suite(C) || C <- string:lexemes(Ciphers0, ":")], binary_cipher_suites(Version, Ciphers). +tuple_to_map({Kex, Cipher, Mac}) -> + #{key_exchange => Kex, + cipher => Cipher, + mac => Mac, + prf => default_prf}; +tuple_to_map({Kex, Cipher, Mac, Prf}) -> + #{key_exchange => Kex, + cipher => Cipher, + mac => Mac, + prf => Prf}. + handle_eccs_option(Value, Version) when is_list(Value) -> {_Major, Minor} = tls_version(Version), try tls_v1:ecc_curves(Minor, Value) of diff --git a/lib/ssl/src/ssl_cipher.erl b/lib/ssl/src/ssl_cipher.erl index b6cd22dd13..7c5cff3665 100644 --- a/lib/ssl/src/ssl_cipher.erl +++ b/lib/ssl/src/ssl_cipher.erl @@ -37,27 +37,28 @@ erl_suite_definition/1, cipher_init/3, decipher/6, cipher/5, decipher_aead/6, cipher_aead/6, suite/1, suites/1, all_suites/1, - ec_keyed_suites/0, anonymous_suites/1, psk_suites/1, srp_suites/0, - rc4_suites/1, des_suites/1, openssl_suite/1, openssl_suite_name/1, filter/2, filter_suites/1, + ec_keyed_suites/0, chacha_suites/1, anonymous_suites/1, psk_suites/1, srp_suites/0, + rc4_suites/1, des_suites/1, rsa_suites/1, openssl_suite/1, openssl_suite_name/1, filter/2, filter_suites/1, hash_algorithm/1, sign_algorithm/1, is_acceptable_hash/2, is_fallback/1, random_bytes/1, calc_mac_hash/4, is_stream_ciphersuite/1]). -export_type([cipher_suite/0, - erl_cipher_suite/0, openssl_cipher_suite/0, + erl_cipher_suite/0, old_erl_cipher_suite/0, openssl_cipher_suite/0, hash/0, key_algo/0, sign_algo/0]). --type cipher() :: null |rc4_128 | des_cbc | '3des_ede_cbc' - | aes_128_cbc | aes_256_cbc | aes_128_gcm | aes_256_gcm | chacha20_poly1305. +-type cipher() :: null |rc4_128 | des_cbc | '3des_ede_cbc' | aes_128_cbc | aes_256_cbc | aes_128_gcm | aes_256_gcm | chacha20_poly1305. -type hash() :: null | md5 | sha | sha224 | sha256 | sha384 | sha512. -type sign_algo() :: rsa | dsa | ecdsa. --type key_algo() :: null | rsa | dhe_rsa | dhe_dss | ecdhe_ecdsa| ecdh_ecdsa | ecdh_rsa| srp_rsa| srp_dss | - psk | dhe_psk | rsa_psk | dh_anon | ecdh_anon | srp_anon. --type erl_cipher_suite() :: {key_algo(), cipher(), hash()} % Pre TLS 1.2 - %% TLS 1.2, internally PRE TLS 1.2 will use default_prf - | {key_algo(), cipher(), hash(), hash() | default_prf}. - - +-type key_algo() :: null | rsa | dhe_rsa | dhe_dss | ecdhe_ecdsa| ecdh_ecdsa | ecdh_rsa| srp_rsa| srp_dss | psk | dhe_psk | rsa_psk | dh_anon | ecdh_anon | srp_anon. +-type erl_cipher_suite() :: #{key_exchange := key_algo(), + cipher := cipher(), + mac := hash(), + prf := hash() | default_prf %% Old cipher suites, version dependent + }. +-type old_erl_cipher_suite() :: {key_algo(), cipher(), hash()} % Pre TLS 1.2 + %% TLS 1.2, internally PRE TLS 1.2 will use default_prf + | {key_algo(), cipher(), hash(), hash() | default_prf}. -type cipher_suite() :: binary(). -type cipher_enum() :: integer(). -type openssl_cipher_suite() :: string(). @@ -83,7 +84,8 @@ security_parameters(?TLS_NULL_WITH_NULL_NULL = CipherSuite, SecParams) -> %% cipher values has been updated according to <CipherSuite> %%------------------------------------------------------------------- security_parameters(Version, CipherSuite, SecParams) -> - { _, Cipher, Hash, PrfHashAlg} = suite_definition(CipherSuite), + #{cipher := Cipher, mac := Hash, + prf := PrfHashAlg} = suite_definition(CipherSuite), SecParams#security_parameters{ cipher_suite = CipherSuite, bulk_cipher_algorithm = bulk_cipher_algorithm(Cipher), @@ -318,13 +320,28 @@ suites({_, Minor}) -> all_suites({3, _} = Version) -> suites(Version) - ++ anonymous_suites(Version) + ++ chacha_suites(Version) + ++ anonymous_suites(Version) ++ psk_suites(Version) ++ srp_suites() ++ rc4_suites(Version) - ++ des_suites(Version); + ++ des_suites(Version) + ++ rsa_suites(Version); all_suites(Version) -> dtls_v1:all_suites(Version). +%%-------------------------------------------------------------------- +-spec chacha_suites(ssl_record:ssl_version() | integer()) -> [cipher_suite()]. +%% +%% Description: Returns list of the chacha cipher suites, only supported +%% if explicitly set by user for now due to interop problems, proably need +%% to be fixed in crypto. +%%-------------------------------------------------------------------- +chacha_suites({3, _}) -> + [?TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256, + ?TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256, + ?TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256]; +chacha_suites(_) -> + []. %%-------------------------------------------------------------------- -spec anonymous_suites(ssl_record:ssl_version() | integer()) -> [cipher_suite()]. @@ -332,7 +349,6 @@ all_suites(Version) -> %% Description: Returns a list of the anonymous cipher suites, only supported %% if explicitly set by user. Intended only for testing. %%-------------------------------------------------------------------- - anonymous_suites({3, N}) -> anonymous_suites(N); anonymous_suites({254, _} = Version) -> @@ -371,7 +387,6 @@ anonymous_suites(N) when N == 0; %%-------------------------------------------------------------------- psk_suites({3, N}) -> psk_suites(N); - psk_suites(N) when N >= 3 -> [ @@ -392,7 +407,6 @@ psk_suites(N) ?TLS_RSA_PSK_WITH_AES_128_CBC_SHA256, ?TLS_PSK_WITH_AES_128_CBC_SHA256 ] ++ psk_suites(0); - psk_suites(_) -> [?TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA, ?TLS_DHE_PSK_WITH_AES_256_CBC_SHA, @@ -428,7 +442,7 @@ srp_suites() -> ?TLS_SRP_SHA_RSA_WITH_AES_256_CBC_SHA, ?TLS_SRP_SHA_DSS_WITH_AES_256_CBC_SHA]. %%-------------------------------------------------------------------- --spec rc4_suites(Version::ssl_record:ssl_version()) -> [cipher_suite()]. +-spec rc4_suites(Version::ssl_record:ssl_version() | integer()) -> [cipher_suite()]. %% %% Description: Returns a list of the RSA|(ECDH/RSA)| (ECDH/ECDSA) %% with RC4 cipher suites, only supported if explicitly set by user. @@ -436,13 +450,15 @@ srp_suites() -> %% belonged to the user configured only category. %%-------------------------------------------------------------------- rc4_suites({3, 0}) -> + rc4_suites(0); +rc4_suites({3, Minor}) -> + rc4_suites(Minor) ++ rc4_suites(0); +rc4_suites(0) -> [?TLS_RSA_WITH_RC4_128_SHA, ?TLS_RSA_WITH_RC4_128_MD5]; -rc4_suites({3, N}) when N =< 3 -> +rc4_suites(N) when N =< 3 -> [?TLS_ECDHE_ECDSA_WITH_RC4_128_SHA, ?TLS_ECDHE_RSA_WITH_RC4_128_SHA, - ?TLS_RSA_WITH_RC4_128_SHA, - ?TLS_RSA_WITH_RC4_128_MD5, ?TLS_ECDH_ECDSA_WITH_RC4_128_SHA, ?TLS_ECDH_RSA_WITH_RC4_128_SHA]. %%-------------------------------------------------------------------- @@ -454,9 +470,39 @@ rc4_suites({3, N}) when N =< 3 -> %%-------------------------------------------------------------------- des_suites(_)-> [?TLS_DHE_RSA_WITH_DES_CBC_SHA, - ?TLS_RSA_WITH_DES_CBC_SHA]. + ?TLS_RSA_WITH_DES_CBC_SHA, + ?TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA, + ?TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA, + ?TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA, + ?TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA, + ?TLS_ECDH_ECDSA_WITH_3DES_EDE_CBC_SHA, + ?TLS_ECDH_RSA_WITH_3DES_EDE_CBC_SHA + ]. %%-------------------------------------------------------------------- +-spec rsa_suites(Version::ssl_record:ssl_version() | integer()) -> [cipher_suite()]. +%% +%% Description: Returns a list of the RSA key exchange +%% cipher suites, only supported if explicitly set by user. +%% Are not considered secure any more. +%%-------------------------------------------------------------------- +rsa_suites({3, 0}) -> + rsa_suites(0); +rsa_suites({3, Minor}) -> + rsa_suites(Minor) ++ rsa_suites(0); +rsa_suites(0) -> + [?TLS_RSA_WITH_AES_256_CBC_SHA, + ?TLS_RSA_WITH_AES_128_CBC_SHA, + ?TLS_RSA_WITH_3DES_EDE_CBC_SHA + ]; +rsa_suites(N) when N =< 3 -> + [ + ?TLS_RSA_WITH_AES_256_GCM_SHA384, + ?TLS_RSA_WITH_AES_256_CBC_SHA256, + ?TLS_RSA_WITH_AES_128_GCM_SHA256, + ?TLS_RSA_WITH_AES_128_CBC_SHA256 + ]. +%%-------------------------------------------------------------------- -spec suite_definition(cipher_suite()) -> erl_cipher_suite(). %% %% Description: Return erlang cipher suite definition. @@ -465,353 +511,740 @@ des_suites(_)-> %%------------------------------------------------------------------- %% TLS v1.1 suites suite_definition(?TLS_NULL_WITH_NULL_NULL) -> - {null, null, null, null}; + #{key_exchange => null, + cipher => null, + mac => null, + prf => null}; %% RFC 5746 - Not a real cipher suite used to signal empty "renegotiation_info" extension %% to avoid handshake failure from old servers that do not ignore %% hello extension data as they should. suite_definition(?TLS_EMPTY_RENEGOTIATION_INFO_SCSV) -> - {null, null, null, null}; -%% suite_definition(?TLS_RSA_WITH_NULL_MD5) -> -%% {rsa, null, md5, default_prf}; -%% suite_definition(?TLS_RSA_WITH_NULL_SHA) -> -%% {rsa, null, sha, default_prf}; + #{key_exchange => null, + cipher => null, + mac => null, + prf => null}; suite_definition(?TLS_RSA_WITH_RC4_128_MD5) -> - {rsa, rc4_128, md5, default_prf}; + #{key_exchange => rsa, + cipher => rc4_128, + mac => md5, + prf => default_prf}; suite_definition(?TLS_RSA_WITH_RC4_128_SHA) -> - {rsa, rc4_128, sha, default_prf}; + #{key_exchange => rsa, + cipher => rc4_128, + mac => sha, + prf => default_prf}; suite_definition(?TLS_RSA_WITH_DES_CBC_SHA) -> - {rsa, des_cbc, sha, default_prf}; + #{key_exchange => rsa, + cipher => des_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_RSA_WITH_3DES_EDE_CBC_SHA) -> - {rsa, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => rsa, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_DHE_DSS_WITH_DES_CBC_SHA) -> - {dhe_dss, des_cbc, sha, default_prf}; + #{key_exchange => dhe_dss, + cipher => des_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA) -> - {dhe_dss, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => dhe_dss, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_DHE_RSA_WITH_DES_CBC_SHA) -> - {dhe_rsa, des_cbc, sha, default_prf}; + #{key_exchange => dhe_rsa, + cipher => des_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA) -> - {dhe_rsa, '3des_ede_cbc', sha, default_prf}; - + #{key_exchange => dhe_rsa, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; %%% TSL V1.1 AES suites suite_definition(?TLS_RSA_WITH_AES_128_CBC_SHA) -> - {rsa, aes_128_cbc, sha, default_prf}; + #{key_exchange => rsa, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_DHE_DSS_WITH_AES_128_CBC_SHA) -> - {dhe_dss, aes_128_cbc, sha, default_prf}; + #{key_exchange => dhe_dss, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_DHE_RSA_WITH_AES_128_CBC_SHA) -> - {dhe_rsa, aes_128_cbc, sha, default_prf}; + #{key_exchange => dhe_rsa, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_RSA_WITH_AES_256_CBC_SHA) -> - {rsa, aes_256_cbc, sha, default_prf}; + #{key_exchange => rsa, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_DHE_DSS_WITH_AES_256_CBC_SHA) -> - {dhe_dss, aes_256_cbc, sha, default_prf}; + #{key_exchange => dhe_dss, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_DHE_RSA_WITH_AES_256_CBC_SHA) -> - {dhe_rsa, aes_256_cbc, sha, default_prf}; - + #{key_exchange => dhe_rsa, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; %% TLS v1.2 suites - %% suite_definition(?TLS_RSA_WITH_NULL_SHA) -> %% {rsa, null, sha, default_prf}; suite_definition(?TLS_RSA_WITH_AES_128_CBC_SHA256) -> - {rsa, aes_128_cbc, sha256, default_prf}; + #{key_exchange => rsa, + cipher => aes_128_cbc, + mac => sha256, + prf => default_prf}; suite_definition(?TLS_RSA_WITH_AES_256_CBC_SHA256) -> - {rsa, aes_256_cbc, sha256, default_prf}; + #{key_exchange => rsa, + cipher => aes_256_cbc, + mac => sha256, + prf => default_prf}; suite_definition(?TLS_DHE_DSS_WITH_AES_128_CBC_SHA256) -> - {dhe_dss, aes_128_cbc, sha256, default_prf}; + #{key_exchange => dhe_dss, + cipher => aes_128_cbc, + mac => sha256, + prf => default_prf}; suite_definition(?TLS_DHE_RSA_WITH_AES_128_CBC_SHA256) -> - {dhe_rsa, aes_128_cbc, sha256, default_prf}; + #{key_exchange => dhe_rsa, + cipher => aes_128_cbc, + mac => sha256, + prf => default_prf}; suite_definition(?TLS_DHE_DSS_WITH_AES_256_CBC_SHA256) -> - {dhe_dss, aes_256_cbc, sha256, default_prf}; + #{key_exchange => dhe_dss, + cipher => aes_256_cbc, + mac => sha256, + prf => default_prf}; suite_definition(?TLS_DHE_RSA_WITH_AES_256_CBC_SHA256) -> - {dhe_rsa, aes_256_cbc, sha256, default_prf}; - + #{key_exchange => dhe_rsa, + cipher => aes_256_cbc, + mac => sha256, + prf => default_prf}; %% not defined YET: %% TLS_DH_DSS_WITH_AES_128_CBC_SHA256 DH_DSS AES_128_CBC SHA256 %% TLS_DH_RSA_WITH_AES_128_CBC_SHA256 DH_RSA AES_128_CBC SHA256 %% TLS_DH_DSS_WITH_AES_256_CBC_SHA256 DH_DSS AES_256_CBC SHA256 %% TLS_DH_RSA_WITH_AES_256_CBC_SHA256 DH_RSA AES_256_CBC SHA256 - %%% DH-ANON deprecated by TLS spec and not available %%% by default, but good for testing purposes. suite_definition(?TLS_DH_anon_WITH_RC4_128_MD5) -> - {dh_anon, rc4_128, md5, default_prf}; + #{key_exchange => dh_anon, + cipher => rc4_128, + mac => md5, + prf => default_prf}; suite_definition(?TLS_DH_anon_WITH_DES_CBC_SHA) -> - {dh_anon, des_cbc, sha, default_prf}; + #{key_exchange => dh_anon, + cipher => des_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_DH_anon_WITH_3DES_EDE_CBC_SHA) -> - {dh_anon, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => dh_anon, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_DH_anon_WITH_AES_128_CBC_SHA) -> - {dh_anon, aes_128_cbc, sha, default_prf}; + #{key_exchange => dh_anon, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_DH_anon_WITH_AES_256_CBC_SHA) -> - {dh_anon, aes_256_cbc, sha, default_prf}; + #{key_exchange => dh_anon, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_DH_anon_WITH_AES_128_CBC_SHA256) -> - {dh_anon, aes_128_cbc, sha256, default_prf}; + #{key_exchange => dh_anon, + cipher => aes_128_cbc, + mac => sha256, + prf => default_prf}; suite_definition(?TLS_DH_anon_WITH_AES_256_CBC_SHA256) -> - {dh_anon, aes_256_cbc, sha256, default_prf}; - + #{key_exchange => dh_anon, + cipher => aes_256_cbc, + mac => sha256, + prf => default_prf}; %%% PSK Cipher Suites RFC 4279 - suite_definition(?TLS_PSK_WITH_RC4_128_SHA) -> - {psk, rc4_128, sha, default_prf}; + #{key_exchange => psk, + cipher => rc4_128, + mac => sha, + prf => default_prf}; suite_definition(?TLS_PSK_WITH_3DES_EDE_CBC_SHA) -> - {psk, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => psk, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_PSK_WITH_AES_128_CBC_SHA) -> - {psk, aes_128_cbc, sha, default_prf}; + #{key_exchange => psk, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_PSK_WITH_AES_256_CBC_SHA) -> - {psk, aes_256_cbc, sha, default_prf}; + #{key_exchange => psk, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_DHE_PSK_WITH_RC4_128_SHA) -> - {dhe_psk, rc4_128, sha, default_prf}; + #{key_exchange => dhe_psk, + cipher => rc4_128, + mac => sha, + prf => default_prf}; suite_definition(?TLS_DHE_PSK_WITH_3DES_EDE_CBC_SHA) -> - {dhe_psk, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => dhe_psk, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_DHE_PSK_WITH_AES_128_CBC_SHA) -> - {dhe_psk, aes_128_cbc, sha, default_prf}; + #{key_exchange => dhe_psk, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_DHE_PSK_WITH_AES_256_CBC_SHA) -> - {dhe_psk, aes_256_cbc, sha, default_prf}; + #{key_exchange => dhe_psk, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_RSA_PSK_WITH_RC4_128_SHA) -> - {rsa_psk, rc4_128, sha, default_prf}; + #{key_exchange => rsa_psk, + cipher => rc4_128, + mac => sha, + prf => default_prf}; suite_definition(?TLS_RSA_PSK_WITH_3DES_EDE_CBC_SHA) -> - {rsa_psk, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => rsa_psk, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_RSA_PSK_WITH_AES_128_CBC_SHA) -> - {rsa_psk, aes_128_cbc, sha, default_prf}; + #{key_exchange => rsa_psk, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_RSA_PSK_WITH_AES_256_CBC_SHA) -> - {rsa_psk, aes_256_cbc, sha, default_prf}; - + #{key_exchange => rsa_psk, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; %%% PSK NULL Cipher Suites RFC 4785 - suite_definition(?TLS_PSK_WITH_NULL_SHA) -> - {psk, null, sha, default_prf}; + #{key_exchange => psk, + cipher => null, + mac => sha, + prf => default_prf}; suite_definition(?TLS_DHE_PSK_WITH_NULL_SHA) -> - {dhe_psk, null, sha, default_prf}; + #{key_exchange => dhe_psk, + cipher => null, + mac => sha, + prf => default_prf}; suite_definition(?TLS_RSA_PSK_WITH_NULL_SHA) -> - {rsa_psk, null, sha, default_prf}; - + #{key_exchange => rsa_psk, + cipher => null, + mac => sha, + prf => default_prf}; %%% TLS 1.2 PSK Cipher Suites RFC 5487 - suite_definition(?TLS_PSK_WITH_AES_128_GCM_SHA256) -> - {psk, aes_128_gcm, null, sha256}; + #{key_exchange => psk, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; suite_definition(?TLS_PSK_WITH_AES_256_GCM_SHA384) -> - {psk, aes_256_gcm, null, sha384}; + #{key_exchange => psk, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; suite_definition(?TLS_DHE_PSK_WITH_AES_128_GCM_SHA256) -> - {dhe_psk, aes_128_gcm, null, sha256}; + #{key_exchange => dhe_psk, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; suite_definition(?TLS_DHE_PSK_WITH_AES_256_GCM_SHA384) -> - {dhe_psk, aes_256_gcm, null, sha384}; + #{key_exchange => dhe_psk, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; suite_definition(?TLS_RSA_PSK_WITH_AES_128_GCM_SHA256) -> - {rsa_psk, aes_128_gcm, null, sha256}; + #{key_exchange => rsa_psk, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; suite_definition(?TLS_RSA_PSK_WITH_AES_256_GCM_SHA384) -> - {rsa_psk, aes_256_gcm, null, sha384}; - + #{key_exchange => rsa_psk, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; suite_definition(?TLS_PSK_WITH_AES_128_CBC_SHA256) -> - {psk, aes_128_cbc, sha256, default_prf}; + #{key_exchange => psk, + cipher => aes_128_cbc, + mac => sha256, + prf => default_prf}; suite_definition(?TLS_PSK_WITH_AES_256_CBC_SHA384) -> - {psk, aes_256_cbc, sha384, default_prf}; + #{key_exchange => psk, + cipher => aes_256_cbc, + mac => sha384, + prf => default_prf}; suite_definition(?TLS_DHE_PSK_WITH_AES_128_CBC_SHA256) -> - {dhe_psk, aes_128_cbc, sha256, default_prf}; + #{key_exchange => dhe_psk, + cipher => aes_128_cbc, + mac => sha256, + prf => default_prf}; suite_definition(?TLS_DHE_PSK_WITH_AES_256_CBC_SHA384) -> - {dhe_psk, aes_256_cbc, sha384, default_prf}; + #{key_exchange => dhe_psk, + cipher => aes_256_cbc, + mac => sha384, + prf => default_prf}; suite_definition(?TLS_RSA_PSK_WITH_AES_128_CBC_SHA256) -> - {rsa_psk, aes_128_cbc, sha256, default_prf}; + #{key_exchange => rsa_psk, + cipher => aes_128_cbc, + mac => sha256, + prf => default_prf}; suite_definition(?TLS_RSA_PSK_WITH_AES_256_CBC_SHA384) -> - {rsa_psk, aes_256_cbc, sha384, default_prf}; - + #{key_exchange => rsa_psk, + cipher => aes_256_cbc, + mac => sha384, + prf => default_prf}; suite_definition(?TLS_PSK_WITH_NULL_SHA256) -> - {psk, null, sha256, default_prf}; + #{key_exchange => psk, + cipher => null, + mac => sha256, + prf => default_prf}; suite_definition(?TLS_PSK_WITH_NULL_SHA384) -> - {psk, null, sha384, default_prf}; + #{key_exchange => psk, + cipher => null, + mac => sha384, + prf => default_prf}; suite_definition(?TLS_DHE_PSK_WITH_NULL_SHA256) -> - {dhe_psk, null, sha256, default_prf}; + #{key_exchange => dhe_psk, + cipher => null, + mac => sha256, + prf => default_prf}; suite_definition(?TLS_DHE_PSK_WITH_NULL_SHA384) -> - {dhe_psk, null, sha384, default_prf}; + #{key_exchange => dhe_psk, + cipher => null, + mac => sha384, + prf => default_prf}; suite_definition(?TLS_RSA_PSK_WITH_NULL_SHA256) -> - {rsa_psk, null, sha256, default_prf}; + #{key_exchange => rsa_psk, + cipher => null, + mac => sha256, + prf => default_prf}; suite_definition(?TLS_RSA_PSK_WITH_NULL_SHA384) -> - {rsa_psk, null, sha384, default_prf}; - + #{key_exchange => rsa_psk, + cipher => null, + mac => sha384, + prf => default_prf}; %%% ECDHE PSK Cipher Suites RFC 5489 - suite_definition(?TLS_ECDHE_PSK_WITH_RC4_128_SHA) -> - {ecdhe_psk, rc4_128, sha, default_prf}; + #{key_exchange => ecdhe_psk, + cipher => rc4_128, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDHE_PSK_WITH_3DES_EDE_CBC_SHA) -> - {ecdhe_psk, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => ecdhe_psk, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA) -> - {ecdhe_psk, aes_128_cbc, sha, default_prf}; + #{key_exchange => ecdhe_psk, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA) -> - {ecdhe_psk, aes_256_cbc, sha, default_prf}; + #{key_exchange => ecdhe_psk, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA256) -> - {ecdhe_psk, aes_128_cbc, sha256, default_prf}; + #{key_exchange => ecdhe_psk, + cipher => aes_128_cbc, + mac => sha256, + prf => default_prf}; suite_definition(?TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA384) -> - {ecdhe_psk, aes_256_cbc, sha384, default_prf}; + #{key_exchange => ecdhe_psk, + cipher => aes_256_cbc, + mac => sha384, + prf => default_prf}; suite_definition(?TLS_ECDHE_PSK_WITH_NULL_SHA256) -> - {ecdhe_psk, null, sha256, default_prf}; + #{key_exchange => ecdhe_psk, + cipher => null, + mac => sha256, + prf => default_prf}; suite_definition(?TLS_ECDHE_PSK_WITH_NULL_SHA384) -> - {ecdhe_psk, null, sha384, default_prf}; - + #{key_exchange => ecdhe_psk, + cipher => null, mac => sha384, + prf => default_prf}; %%% ECDHE_PSK with AES-GCM and AES-CCM Cipher Suites, draft-ietf-tls-ecdhe-psk-aead-05 - suite_definition(?TLS_ECDHE_PSK_WITH_AES_128_GCM_SHA256) -> - {ecdhe_psk, aes_128_gcm, null, sha256}; + #{key_exchange => ecdhe_psk, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; suite_definition(?TLS_ECDHE_PSK_WITH_AES_256_GCM_SHA384) -> - {ecdhe_psk, aes_256_gcm, null, sha384}; + #{key_exchange => ecdhe_psk, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; %% suite_definition(?TLS_ECDHE_PSK_WITH_AES_128_CCM_8_SHA256) -> -%% {ecdhe_psk, aes_128_ccm, null, sha256}; +%% #{key_exchange => ecdhe_psk, +%% cipher => aes_128_ccm, +%% mac => null, +%% prf =>sha256}; %% suite_definition(?TLS_ECDHE_PSK_WITH_AES_128_CCM_SHA256) -> -%% {ecdhe_psk, aes_256_ccm, null, sha256}; - +%% #{key_exchange => ecdhe_psk, +%% cipher => aes_256_ccm, +%% mac => null, +%% prf => sha256}; %%% SRP Cipher Suites RFC 5054 - suite_definition(?TLS_SRP_SHA_WITH_3DES_EDE_CBC_SHA) -> - {srp_anon, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => srp_anon, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_SRP_SHA_RSA_WITH_3DES_EDE_CBC_SHA) -> - {srp_rsa, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => srp_rsa, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_SRP_SHA_DSS_WITH_3DES_EDE_CBC_SHA) -> - {srp_dss, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => srp_dss, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_SRP_SHA_WITH_AES_128_CBC_SHA) -> - {srp_anon, aes_128_cbc, sha, default_prf}; + #{key_exchange => srp_anon, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_SRP_SHA_RSA_WITH_AES_128_CBC_SHA) -> - {srp_rsa, aes_128_cbc, sha, default_prf}; + #{key_exchange => srp_rsa, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_SRP_SHA_DSS_WITH_AES_128_CBC_SHA) -> - {srp_dss, aes_128_cbc, sha, default_prf}; + #{key_exchange => srp_dss, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_SRP_SHA_WITH_AES_256_CBC_SHA) -> - {srp_anon, aes_256_cbc, sha, default_prf}; + #{key_exchange => srp_anon, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_SRP_SHA_RSA_WITH_AES_256_CBC_SHA) -> - {srp_rsa, aes_256_cbc, sha, default_prf}; + #{key_exchange => srp_rsa, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_SRP_SHA_DSS_WITH_AES_256_CBC_SHA) -> - {srp_dss, aes_256_cbc, sha, default_prf}; - + #{key_exchange => srp_dss, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; %% RFC 4492 EC TLS suites suite_definition(?TLS_ECDH_ECDSA_WITH_NULL_SHA) -> - {ecdh_ecdsa, null, sha, default_prf}; + #{key_exchange => ecdh_ecdsa, + cipher => null, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDH_ECDSA_WITH_RC4_128_SHA) -> - {ecdh_ecdsa, rc4_128, sha, default_prf}; + #{key_exchange => ecdh_ecdsa, + cipher => rc4_128, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDH_ECDSA_WITH_3DES_EDE_CBC_SHA) -> - {ecdh_ecdsa, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => ecdh_ecdsa, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA) -> - {ecdh_ecdsa, aes_128_cbc, sha, default_prf}; + #{key_exchange => ecdh_ecdsa, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA) -> - {ecdh_ecdsa, aes_256_cbc, sha, default_prf}; - + #{key_exchange => ecdh_ecdsa, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDHE_ECDSA_WITH_NULL_SHA) -> - {ecdhe_ecdsa, null, sha, default_prf}; + #{key_exchange => ecdhe_ecdsa, + cipher => null, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDHE_ECDSA_WITH_RC4_128_SHA) -> - {ecdhe_ecdsa, rc4_128, sha, default_prf}; + #{key_exchange => ecdhe_ecdsa, + cipher => rc4_128, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA) -> - {ecdhe_ecdsa, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => ecdhe_ecdsa, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA) -> - {ecdhe_ecdsa, aes_128_cbc, sha, default_prf}; + #{key_exchange => ecdhe_ecdsa, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA) -> - {ecdhe_ecdsa, aes_256_cbc, sha, default_prf}; - + #{key_exchange => ecdhe_ecdsa, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDH_RSA_WITH_NULL_SHA) -> - {ecdh_rsa, null, sha, default_prf}; + #{key_exchange => ecdh_rsa, + cipher => null, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDH_RSA_WITH_RC4_128_SHA) -> - {ecdh_rsa, rc4_128, sha, default_prf}; + #{key_exchange => ecdh_rsa, + cipher => rc4_128, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDH_RSA_WITH_3DES_EDE_CBC_SHA) -> - {ecdh_rsa, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => ecdh_rsa, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA) -> - {ecdh_rsa, aes_128_cbc, sha, default_prf}; + #{key_exchange => ecdh_rsa, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA) -> - {ecdh_rsa, aes_256_cbc, sha, default_prf}; - + #{key_exchange => ecdh_rsa, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDHE_RSA_WITH_NULL_SHA) -> - {ecdhe_rsa, null, sha, default_prf}; + #{key_exchange => ecdhe_rsa, + cipher => null, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDHE_RSA_WITH_RC4_128_SHA) -> - {ecdhe_rsa, rc4_128, sha, default_prf}; + #{key_exchange => ecdhe_rsa, + cipher => rc4_128, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA) -> - {ecdhe_rsa, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => ecdhe_rsa, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA) -> - {ecdhe_rsa, aes_128_cbc, sha, default_prf}; + #{key_exchange => ecdhe_rsa, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA) -> - {ecdhe_rsa, aes_256_cbc, sha, default_prf}; - + #{key_exchange => ecdhe_rsa, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDH_anon_WITH_NULL_SHA) -> - {ecdh_anon, null, sha, default_prf}; + #{key_exchange => ecdh_anon, + cipher => null, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDH_anon_WITH_RC4_128_SHA) -> - {ecdh_anon, rc4_128, sha, default_prf}; + #{key_exchange => ecdh_anon, + cipher => rc4_128, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDH_anon_WITH_3DES_EDE_CBC_SHA) -> - {ecdh_anon, '3des_ede_cbc', sha, default_prf}; + #{key_exchange => ecdh_anon, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDH_anon_WITH_AES_128_CBC_SHA) -> - {ecdh_anon, aes_128_cbc, sha, default_prf}; + #{key_exchange => ecdh_anon, + cipher => aes_128_cbc, + mac => sha, + prf => default_prf}; suite_definition(?TLS_ECDH_anon_WITH_AES_256_CBC_SHA) -> - {ecdh_anon, aes_256_cbc, sha, default_prf}; - + #{key_exchange => ecdh_anon, + cipher => aes_256_cbc, + mac => sha, + prf => default_prf}; %% RFC 5289 EC TLS suites suite_definition(?TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256) -> - {ecdhe_ecdsa, aes_128_cbc, sha256, sha256}; + #{key_exchange => ecdhe_ecdsa, + cipher => aes_128_cbc, + mac => sha256, + prf => sha256}; suite_definition(?TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384) -> - {ecdhe_ecdsa, aes_256_cbc, sha384, sha384}; + #{key_exchange => ecdhe_ecdsa, + cipher => aes_256_cbc, + mac => sha384, + prf => sha384}; suite_definition(?TLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA256) -> - {ecdh_ecdsa, aes_128_cbc, sha256, sha256}; + #{key_exchange => ecdh_ecdsa, + cipher => aes_128_cbc, + mac => sha256, + prf => sha256}; suite_definition(?TLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA384) -> - {ecdh_ecdsa, aes_256_cbc, sha384, sha384}; + #{key_exchange => ecdh_ecdsa, + cipher => aes_256_cbc, + mac => sha384, + prf => sha384}; suite_definition(?TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256) -> - {ecdhe_rsa, aes_128_cbc, sha256, sha256}; + #{key_exchange => ecdhe_rsa, + cipher => aes_128_cbc, + mac => sha256, + prf => sha256}; suite_definition(?TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384) -> - {ecdhe_rsa, aes_256_cbc, sha384, sha384}; + #{key_exchange => ecdhe_rsa, + cipher => aes_256_cbc, + mac => sha384, + prf => sha384}; suite_definition(?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA256) -> - {ecdh_rsa, aes_128_cbc, sha256, sha256}; + #{key_exchange => ecdh_rsa, + cipher => aes_128_cbc, + mac => sha256, + prf => sha256}; suite_definition(?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384) -> - {ecdh_rsa, aes_256_cbc, sha384, sha384}; - + #{key_exchange => ecdh_rsa, + cipher => aes_256_cbc, + mac => sha384, + prf => sha384}; %% RFC 5288 AES-GCM Cipher Suites suite_definition(?TLS_RSA_WITH_AES_128_GCM_SHA256) -> - {rsa, aes_128_gcm, null, sha256}; + #{key_exchange => rsa, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; suite_definition(?TLS_RSA_WITH_AES_256_GCM_SHA384) -> - {rsa, aes_256_gcm, null, sha384}; + #{key_exchange => rsa, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; suite_definition(?TLS_DHE_RSA_WITH_AES_128_GCM_SHA256) -> - {dhe_rsa, aes_128_gcm, null, sha256}; + #{key_exchange => dhe_rsa, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; suite_definition(?TLS_DHE_RSA_WITH_AES_256_GCM_SHA384) -> - {dhe_rsa, aes_256_gcm, null, sha384}; + #{key_exchange => dhe_rsa, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; suite_definition(?TLS_DH_RSA_WITH_AES_128_GCM_SHA256) -> - {dh_rsa, aes_128_gcm, null, sha256}; + #{key_exchange => dh_rsa, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; suite_definition(?TLS_DH_RSA_WITH_AES_256_GCM_SHA384) -> - {dh_rsa, aes_256_gcm, null, sha384}; + #{key_exchange => dh_rsa, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; suite_definition(?TLS_DHE_DSS_WITH_AES_128_GCM_SHA256) -> - {dhe_dss, aes_128_gcm, null, sha256}; + #{key_exchange => dhe_dss, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; suite_definition(?TLS_DHE_DSS_WITH_AES_256_GCM_SHA384) -> - {dhe_dss, aes_256_gcm, null, sha384}; + #{key_exchange => dhe_dss, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; suite_definition(?TLS_DH_DSS_WITH_AES_128_GCM_SHA256) -> - {dh_dss, aes_128_gcm, null, sha256}; + #{key_exchange => dh_dss, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; suite_definition(?TLS_DH_DSS_WITH_AES_256_GCM_SHA384) -> - {dh_dss, aes_256_gcm, null, sha384}; + #{key_exchange => dh_dss, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; suite_definition(?TLS_DH_anon_WITH_AES_128_GCM_SHA256) -> - {dh_anon, aes_128_gcm, null, sha256}; + #{key_exchange => dh_anon, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; suite_definition(?TLS_DH_anon_WITH_AES_256_GCM_SHA384) -> - {dh_anon, aes_256_gcm, null, sha384}; - + #{key_exchange => dh_anon, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; %% RFC 5289 ECC AES-GCM Cipher Suites suite_definition(?TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256) -> - {ecdhe_ecdsa, aes_128_gcm, null, sha256}; + #{key_exchange => ecdhe_ecdsa, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; suite_definition(?TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384) -> - {ecdhe_ecdsa, aes_256_gcm, null, sha384}; + #{key_exchange => ecdhe_ecdsa, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; suite_definition(?TLS_ECDH_ECDSA_WITH_AES_128_GCM_SHA256) -> - {ecdh_ecdsa, aes_128_gcm, null, sha256}; + #{key_exchange => ecdh_ecdsa, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; suite_definition(?TLS_ECDH_ECDSA_WITH_AES_256_GCM_SHA384) -> - {ecdh_ecdsa, aes_256_gcm, null, sha384}; + #{key_exchange => ecdh_ecdsa, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; suite_definition(?TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256) -> - {ecdhe_rsa, aes_128_gcm, null, sha256}; + #{key_exchange => ecdhe_rsa, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; suite_definition(?TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384) -> - {ecdhe_rsa, aes_256_gcm, null, sha384}; + #{key_exchange => ecdhe_rsa, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; suite_definition(?TLS_ECDH_RSA_WITH_AES_128_GCM_SHA256) -> - {ecdh_rsa, aes_128_gcm, null, sha256}; + #{key_exchange => ecdh_rsa, + cipher => aes_128_gcm, + mac => null, + prf => sha256}; suite_definition(?TLS_ECDH_RSA_WITH_AES_256_GCM_SHA384) -> - {ecdh_rsa, aes_256_gcm, null, sha384}; - + #{key_exchange => ecdh_rsa, + cipher => aes_256_gcm, + mac => null, + prf => sha384}; %% draft-agl-tls-chacha20poly1305-04 Chacha20/Poly1305 Suites suite_definition(?TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256) -> - {ecdhe_rsa, chacha20_poly1305, null, sha256}; + #{key_exchange => ecdhe_rsa, + cipher => chacha20_poly1305, + mac => null, + prf => sha256}; suite_definition(?TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256) -> - {ecdhe_ecdsa, chacha20_poly1305, null, sha256}; + #{key_exchange => ecdhe_ecdsa, + cipher => chacha20_poly1305, + mac => null, + prf => sha256}; suite_definition(?TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256) -> - {dhe_rsa, chacha20_poly1305, null, sha256}. + #{key_exchange => dhe_rsa, + cipher => chacha20_poly1305, + mac => null, + prf => sha256}. %%-------------------------------------------------------------------- --spec erl_suite_definition(cipher_suite()) -> erl_cipher_suite(). +-spec erl_suite_definition(cipher_suite() | erl_cipher_suite()) -> old_erl_cipher_suite(). %% %% Description: Return erlang cipher suite definition. Filters last value %% for now (compatibility reasons). %%-------------------------------------------------------------------- -erl_suite_definition(S) -> - case suite_definition(S) of - {KeyExchange, Cipher, Hash, default_prf} -> +erl_suite_definition(Bin) when is_binary(Bin) -> + erl_suite_definition(suite_definition(Bin)); +erl_suite_definition(#{key_exchange := KeyExchange, cipher := Cipher, + mac := Hash, prf := Prf}) -> + case Prf of + default_prf -> {KeyExchange, Cipher, Hash}; - Suite -> - Suite + _ -> + {KeyExchange, Cipher, Hash, Prf} end. %%-------------------------------------------------------------------- @@ -819,327 +1252,607 @@ erl_suite_definition(S) -> %% %% Description: Return TLS cipher suite definition. %%-------------------------------------------------------------------- - %% TLS v1.1 suites -%%suite({rsa, null, md5}) -> -%% ?TLS_RSA_WITH_NULL_MD5; -%%suite({rsa, null, sha}) -> -%% ?TLS_RSA_WITH_NULL_SHA; -suite({rsa, rc4_128, md5}) -> +suite(#{key_exchange := rsa, + cipher := rc4_128, + mac := md5}) -> ?TLS_RSA_WITH_RC4_128_MD5; -suite({rsa, rc4_128, sha}) -> +suite(#{key_exchange := rsa, + cipher := rc4_128, + mac := sha}) -> ?TLS_RSA_WITH_RC4_128_SHA; -suite({rsa, des_cbc, sha}) -> +suite(#{key_exchange := rsa, + cipher := des_cbc, + mac := sha}) -> ?TLS_RSA_WITH_DES_CBC_SHA; -suite({rsa, '3des_ede_cbc', sha}) -> +suite(#{key_exchange := rsa, + cipher :='3des_ede_cbc', + mac := sha}) -> ?TLS_RSA_WITH_3DES_EDE_CBC_SHA; -suite({dhe_dss, des_cbc, sha}) -> +suite(#{key_exchange := dhe_dss, + cipher:= des_cbc, + mac := sha}) -> ?TLS_DHE_DSS_WITH_DES_CBC_SHA; -suite({dhe_dss, '3des_ede_cbc', sha}) -> +suite(#{key_exchange := dhe_dss, + cipher:= '3des_ede_cbc', + mac := sha}) -> ?TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA; -suite({dhe_rsa, des_cbc, sha}) -> +suite(#{key_exchange := dhe_rsa, + cipher:= des_cbc, + mac := sha}) -> ?TLS_DHE_RSA_WITH_DES_CBC_SHA; -suite({dhe_rsa, '3des_ede_cbc', sha}) -> +suite(#{key_exchange := dhe_rsa, + cipher:= '3des_ede_cbc', + mac := sha}) -> ?TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA; -suite({dh_anon, rc4_128, md5}) -> +suite(#{key_exchange := dh_anon, + cipher:= rc4_128, + mac := md5}) -> ?TLS_DH_anon_WITH_RC4_128_MD5; -suite({dh_anon, des_cbc, sha}) -> +suite(#{key_exchange := dh_anon, + cipher:= des_cbc, + mac := sha}) -> ?TLS_DH_anon_WITH_DES_CBC_SHA; -suite({dh_anon, '3des_ede_cbc', sha}) -> +suite(#{key_exchange := dh_anon, + cipher:= '3des_ede_cbc', + mac := sha}) -> ?TLS_DH_anon_WITH_3DES_EDE_CBC_SHA; - %%% TSL V1.1 AES suites -suite({rsa, aes_128_cbc, sha}) -> +suite(#{key_exchange := rsa, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_RSA_WITH_AES_128_CBC_SHA; -suite({dhe_dss, aes_128_cbc, sha}) -> +suite(#{key_exchange := dhe_dss, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_DHE_DSS_WITH_AES_128_CBC_SHA; -suite({dhe_rsa, aes_128_cbc, sha}) -> +suite(#{key_exchange := dhe_rsa, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_DHE_RSA_WITH_AES_128_CBC_SHA; -suite({dh_anon, aes_128_cbc, sha}) -> +suite(#{key_exchange := dh_anon, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_DH_anon_WITH_AES_128_CBC_SHA; -suite({rsa, aes_256_cbc, sha}) -> +suite(#{key_exchange := rsa, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_RSA_WITH_AES_256_CBC_SHA; -suite({dhe_dss, aes_256_cbc, sha}) -> +suite(#{key_exchange := dhe_dss, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_DHE_DSS_WITH_AES_256_CBC_SHA; -suite({dhe_rsa, aes_256_cbc, sha}) -> +suite(#{key_exchange := dhe_rsa, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_DHE_RSA_WITH_AES_256_CBC_SHA; -suite({dh_anon, aes_256_cbc, sha}) -> +suite(#{key_exchange := dh_anon, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_DH_anon_WITH_AES_256_CBC_SHA; - %% TLS v1.2 suites - -%% suite_definition(?TLS_RSA_WITH_NULL_SHA) -> -%% {rsa, null, sha, sha256}; -suite({rsa, aes_128_cbc, sha256}) -> +suite(#{key_exchange := rsa, + cipher := aes_128_cbc, + mac := sha256}) -> ?TLS_RSA_WITH_AES_128_CBC_SHA256; -suite({rsa, aes_256_cbc, sha256}) -> +suite(#{key_exchange := rsa, + cipher := aes_256_cbc, + mac := sha256}) -> ?TLS_RSA_WITH_AES_256_CBC_SHA256; -suite({dhe_dss, aes_128_cbc, sha256}) -> +suite(#{key_exchange := dhe_dss, + cipher := aes_128_cbc, + mac := sha256}) -> ?TLS_DHE_DSS_WITH_AES_128_CBC_SHA256; -suite({dhe_rsa, aes_128_cbc, sha256}) -> +suite(#{key_exchange := dhe_rsa, + cipher := aes_128_cbc, + mac := sha256}) -> ?TLS_DHE_RSA_WITH_AES_128_CBC_SHA256; -suite({dhe_dss, aes_256_cbc, sha256}) -> +suite(#{key_exchange := dhe_dss, + cipher := aes_256_cbc, + mac := sha256}) -> ?TLS_DHE_DSS_WITH_AES_256_CBC_SHA256; -suite({dhe_rsa, aes_256_cbc, sha256}) -> +suite(#{key_exchange := dhe_rsa, + cipher := aes_256_cbc, + mac := sha256}) -> ?TLS_DHE_RSA_WITH_AES_256_CBC_SHA256; -suite({dh_anon, aes_128_cbc, sha256}) -> +suite(#{key_exchange := dh_anon, + cipher := aes_128_cbc, + mac := sha256}) -> ?TLS_DH_anon_WITH_AES_128_CBC_SHA256; -suite({dh_anon, aes_256_cbc, sha256}) -> +suite(#{key_exchange := dh_anon, + cipher := aes_256_cbc, + mac := sha256}) -> ?TLS_DH_anon_WITH_AES_256_CBC_SHA256; - %%% PSK Cipher Suites RFC 4279 - -suite({psk, rc4_128,sha}) -> +suite(#{key_exchange := psk, + cipher := rc4_128, + mac := sha}) -> ?TLS_PSK_WITH_RC4_128_SHA; -suite({psk, '3des_ede_cbc',sha}) -> +suite(#{key_exchange := psk, + cipher := '3des_ede_cbc', + mac := sha}) -> ?TLS_PSK_WITH_3DES_EDE_CBC_SHA; -suite({psk, aes_128_cbc,sha}) -> +suite(#{key_exchange := psk, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_PSK_WITH_AES_128_CBC_SHA; -suite({psk, aes_256_cbc,sha}) -> +suite(#{key_exchange := psk, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_PSK_WITH_AES_256_CBC_SHA; -suite({dhe_psk, rc4_128,sha}) -> +suite(#{key_exchange := dhe_psk, + cipher := rc4_128, + mac := sha}) -> ?TLS_DHE_PSK_WITH_RC4_128_SHA; -suite({dhe_psk, '3des_ede_cbc',sha}) -> +suite(#{key_exchange := dhe_psk, + cipher := '3des_ede_cbc', + mac := sha}) -> ?TLS_DHE_PSK_WITH_3DES_EDE_CBC_SHA; -suite({dhe_psk, aes_128_cbc,sha}) -> +suite(#{key_exchange := dhe_psk, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_DHE_PSK_WITH_AES_128_CBC_SHA; -suite({dhe_psk, aes_256_cbc,sha}) -> +suite(#{key_exchange := dhe_psk, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_DHE_PSK_WITH_AES_256_CBC_SHA; -suite({rsa_psk, rc4_128,sha}) -> +suite(#{key_exchange := rsa_psk, + cipher := rc4_128, + mac := sha}) -> ?TLS_RSA_PSK_WITH_RC4_128_SHA; -suite({rsa_psk, '3des_ede_cbc',sha}) -> +suite(#{key_exchange := rsa_psk, + cipher := '3des_ede_cbc', + mac := sha}) -> ?TLS_RSA_PSK_WITH_3DES_EDE_CBC_SHA; -suite({rsa_psk, aes_128_cbc,sha}) -> +suite(#{key_exchange := rsa_psk, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_RSA_PSK_WITH_AES_128_CBC_SHA; -suite({rsa_psk, aes_256_cbc,sha}) -> +suite(#{key_exchange := rsa_psk, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_RSA_PSK_WITH_AES_256_CBC_SHA; - %%% PSK NULL Cipher Suites RFC 4785 - -suite({psk, null, sha}) -> +suite(#{key_exchange := psk, + cipher := null, + mac := sha}) -> ?TLS_PSK_WITH_NULL_SHA; -suite({dhe_psk, null, sha}) -> +suite(#{key_exchange := dhe_psk, + cipher := null, + mac := sha}) -> ?TLS_DHE_PSK_WITH_NULL_SHA; -suite({rsa_psk, null, sha}) -> +suite(#{key_exchange := rsa_psk, + cipher := null, + mac := sha}) -> ?TLS_RSA_PSK_WITH_NULL_SHA; - %%% TLS 1.2 PSK Cipher Suites RFC 5487 - -suite({psk, aes_128_gcm, null, sha256}) -> +suite(#{key_exchange := psk, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> ?TLS_PSK_WITH_AES_128_GCM_SHA256; -suite({psk, aes_256_gcm, null, sha384}) -> +suite(#{key_exchange := psk, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> ?TLS_PSK_WITH_AES_256_GCM_SHA384; -suite({dhe_psk, aes_128_gcm, null, sha256}) -> +suite(#{key_exchange := dhe_psk, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> ?TLS_DHE_PSK_WITH_AES_128_GCM_SHA256; -suite({dhe_psk, aes_256_gcm, null, sha384}) -> +suite(#{key_exchange := dhe_psk, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> ?TLS_DHE_PSK_WITH_AES_256_GCM_SHA384; -suite({rsa_psk, aes_128_gcm, null, sha256}) -> +suite(#{key_exchange := rsa_psk, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> ?TLS_RSA_PSK_WITH_AES_128_GCM_SHA256; -suite({rsa_psk, aes_256_gcm, null, sha384}) -> +suite(#{key_exchange := rsa_psk, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> ?TLS_RSA_PSK_WITH_AES_256_GCM_SHA384; - -suite({psk, aes_128_cbc, sha256}) -> +suite(#{key_exchange := psk, + cipher := aes_128_cbc, + mac := sha256}) -> ?TLS_PSK_WITH_AES_128_CBC_SHA256; -suite({psk, aes_256_cbc, sha384}) -> +suite(#{key_exchange := psk, + cipher := aes_256_cbc, + mac := sha384}) -> ?TLS_PSK_WITH_AES_256_CBC_SHA384; -suite({dhe_psk, aes_128_cbc, sha256}) -> +suite(#{key_exchange := dhe_psk, + cipher := aes_128_cbc, + mac := sha256}) -> ?TLS_DHE_PSK_WITH_AES_128_CBC_SHA256; -suite({dhe_psk, aes_256_cbc, sha384}) -> +suite(#{key_exchange := dhe_psk, + cipher := aes_256_cbc, + mac := sha384}) -> ?TLS_DHE_PSK_WITH_AES_256_CBC_SHA384; -suite({rsa_psk, aes_128_cbc, sha256}) -> +suite(#{key_exchange := rsa_psk, + cipher := aes_128_cbc, + mac := sha256}) -> ?TLS_RSA_PSK_WITH_AES_128_CBC_SHA256; -suite({rsa_psk, aes_256_cbc, sha384}) -> +suite(#{key_exchange := rsa_psk, + cipher := aes_256_cbc, + mac := sha384}) -> ?TLS_RSA_PSK_WITH_AES_256_CBC_SHA384; - -suite({psk, null, sha256}) -> +suite(#{key_exchange := psk, + cipher := null, + mac := sha256}) -> ?TLS_PSK_WITH_NULL_SHA256; -suite({psk, null, sha384}) -> +suite(#{key_exchange := psk, + cipher := null, + mac := sha384}) -> ?TLS_PSK_WITH_NULL_SHA384; -suite({dhe_psk, null, sha256}) -> +suite(#{key_exchange := dhe_psk, + cipher := null, + mac := sha256}) -> ?TLS_DHE_PSK_WITH_NULL_SHA256; -suite({dhe_psk, null, sha384}) -> +suite(#{key_exchange := dhe_psk, + cipher := null, + mac := sha384}) -> ?TLS_DHE_PSK_WITH_NULL_SHA384; -suite({rsa_psk, null, sha256}) -> +suite(#{key_exchange := rsa_psk, + cipher := null, + mac := sha256}) -> ?TLS_RSA_PSK_WITH_NULL_SHA256; -suite({rsa_psk, null, sha384}) -> +suite(#{key_exchange := rsa_psk, + cipher := null, + mac := sha384}) -> ?TLS_RSA_PSK_WITH_NULL_SHA384; - %%% ECDHE PSK Cipher Suites RFC 5489 - -suite({ecdhe_psk, rc4_128,sha}) -> +suite(#{key_exchange := ecdhe_psk, + cipher := rc4_128, + mac := sha}) -> ?TLS_ECDHE_PSK_WITH_RC4_128_SHA; -suite({ecdhe_psk, '3des_ede_cbc',sha}) -> +suite(#{key_exchange := ecdhe_psk, + cipher :='3des_ede_cbc', + mac := sha}) -> ?TLS_ECDHE_PSK_WITH_3DES_EDE_CBC_SHA; -suite({ecdhe_psk, aes_128_cbc,sha}) -> +suite(#{key_exchange := ecdhe_psk, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA; -suite({ecdhe_psk, aes_256_cbc,sha}) -> +suite(#{key_exchange := ecdhe_psk, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA; -suite({ecdhe_psk, aes_128_cbc, sha256}) -> +suite(#{key_exchange := ecdhe_psk, + cipher := aes_128_cbc, + mac := sha256}) -> ?TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA256; -suite({ecdhe_psk, aes_256_cbc, sha384}) -> +suite(#{key_exchange := ecdhe_psk, + cipher := aes_256_cbc, + mac := sha384}) -> ?TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA384; -suite({ecdhe_psk, null, sha256}) -> +suite(#{key_exchange := ecdhe_psk, + cipher := null, + mac := sha256}) -> ?TLS_ECDHE_PSK_WITH_NULL_SHA256; -suite({ecdhe_psk, null, sha384}) -> +suite(#{key_exchange := ecdhe_psk, + cipher := null, + mac := sha384}) -> ?TLS_ECDHE_PSK_WITH_NULL_SHA384; - %%% ECDHE_PSK with AES-GCM and AES-CCM Cipher Suites, draft-ietf-tls-ecdhe-psk-aead-05 - -suite({ecdhe_psk, aes_128_gcm, null, sha256}) -> +suite(#{key_exchange := ecdhe_psk, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> ?TLS_ECDHE_PSK_WITH_AES_128_GCM_SHA256; -suite({ecdhe_psk, aes_256_gcm, null, sha384}) -> +suite(#{key_exchange := ecdhe_psk, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> ?TLS_ECDHE_PSK_WITH_AES_256_GCM_SHA384; -%% suite({ecdhe_psk, aes_128_ccm, null, sha256}) -> -%% ?TLS_ECDHE_PSK_WITH_AES_128_CCM_8_SHA256; -%% suite({ecdhe_psk, aes_256_ccm, null, sha256}) -> -%% ?TLS_ECDHE_PSK_WITH_AES_128_CCM_SHA256; - + %% suite(#{key_exchange := ecdhe_psk, + %% cipher := aes_128_ccm, + %% mac := null, + %% prf := sha256}) -> + %% ?TLS_ECDHE_PSK_WITH_AES_128_CCM_8_SHA256; + %% suite(#{key_exchange := ecdhe_psk, + %% cipher := aes_256_ccm, + %% mac := null, + %% prf := sha256}) -> + %% ?TLS_ECDHE_PSK_WITH_AES_128_CCM_SHA256; %%% SRP Cipher Suites RFC 5054 - -suite({srp_anon, '3des_ede_cbc', sha}) -> +suite(#{key_exchange := srp_anon, + cipher := '3des_ede_cbc', + mac := sha}) -> ?TLS_SRP_SHA_WITH_3DES_EDE_CBC_SHA; -suite({srp_rsa, '3des_ede_cbc', sha}) -> +suite(#{key_exchange := srp_rsa, + cipher := '3des_ede_cbc', + mac := sha}) -> ?TLS_SRP_SHA_RSA_WITH_3DES_EDE_CBC_SHA; -suite({srp_dss, '3des_ede_cbc', sha}) -> +suite(#{key_exchange := srp_dss, + cipher := '3des_ede_cbc', + mac := sha}) -> ?TLS_SRP_SHA_DSS_WITH_3DES_EDE_CBC_SHA; -suite({srp_anon, aes_128_cbc, sha}) -> +suite(#{key_exchange := srp_anon, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_SRP_SHA_WITH_AES_128_CBC_SHA; -suite({srp_rsa, aes_128_cbc, sha}) -> +suite(#{key_exchange := srp_rsa, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_SRP_SHA_RSA_WITH_AES_128_CBC_SHA; -suite({srp_dss, aes_128_cbc, sha}) -> +suite(#{key_exchange := srp_dss, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_SRP_SHA_DSS_WITH_AES_128_CBC_SHA; -suite({srp_anon, aes_256_cbc, sha}) -> +suite(#{key_exchange := srp_anon, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_SRP_SHA_WITH_AES_256_CBC_SHA; -suite({srp_rsa, aes_256_cbc, sha}) -> +suite(#{key_exchange := srp_rsa, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_SRP_SHA_RSA_WITH_AES_256_CBC_SHA; -suite({srp_dss, aes_256_cbc, sha}) -> +suite(#{key_exchange := srp_dss, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_SRP_SHA_DSS_WITH_AES_256_CBC_SHA; - %%% RFC 4492 EC TLS suites -suite({ecdh_ecdsa, null, sha}) -> +suite(#{key_exchange := ecdh_ecdsa, + cipher := null, + mac := sha}) -> ?TLS_ECDH_ECDSA_WITH_NULL_SHA; -suite({ecdh_ecdsa, rc4_128, sha}) -> +suite(#{key_exchange := ecdh_ecdsa, + cipher := rc4_128, + mac := sha}) -> ?TLS_ECDH_ECDSA_WITH_RC4_128_SHA; -suite({ecdh_ecdsa, '3des_ede_cbc', sha}) -> +suite(#{key_exchange := ecdh_ecdsa, + cipher := '3des_ede_cbc', + mac := sha}) -> ?TLS_ECDH_ECDSA_WITH_3DES_EDE_CBC_SHA; -suite({ecdh_ecdsa, aes_128_cbc, sha}) -> +suite(#{key_exchange := ecdh_ecdsa, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA; -suite({ecdh_ecdsa, aes_256_cbc, sha}) -> +suite(#{key_exchange := ecdh_ecdsa, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA; - -suite({ecdhe_ecdsa, null, sha}) -> +suite(#{key_exchange := ecdhe_ecdsa, + cipher := null, + mac := sha}) -> ?TLS_ECDHE_ECDSA_WITH_NULL_SHA; -suite({ecdhe_ecdsa, rc4_128, sha}) -> +suite(#{key_exchange := ecdhe_ecdsa, + cipher := rc4_128, + mac := sha}) -> ?TLS_ECDHE_ECDSA_WITH_RC4_128_SHA; -suite({ecdhe_ecdsa, '3des_ede_cbc', sha}) -> +suite(#{key_exchange := ecdhe_ecdsa, + cipher := '3des_ede_cbc', + mac := sha}) -> ?TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA; -suite({ecdhe_ecdsa, aes_128_cbc, sha}) -> +suite(#{key_exchange := ecdhe_ecdsa, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA; -suite({ecdhe_ecdsa, aes_256_cbc, sha}) -> +suite(#{key_exchange := ecdhe_ecdsa, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA; - -suite({ecdh_rsa, null, sha}) -> +suite(#{key_exchange := ecdh_rsa, + cipher := null, + mac := sha}) -> ?TLS_ECDH_RSA_WITH_NULL_SHA; -suite({ecdh_rsa, rc4_128, sha}) -> +suite(#{key_exchange := ecdh_rsa, + cipher := rc4_128, + mac := sha}) -> ?TLS_ECDH_RSA_WITH_RC4_128_SHA; -suite({ecdh_rsa, '3des_ede_cbc', sha}) -> +suite(#{key_exchange := ecdh_rsa, + cipher := '3des_ede_cbc', mac := sha}) -> ?TLS_ECDH_RSA_WITH_3DES_EDE_CBC_SHA; -suite({ecdh_rsa, aes_128_cbc, sha}) -> +suite(#{key_exchange := ecdh_rsa, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA; -suite({ecdh_rsa, aes_256_cbc, sha}) -> +suite(#{key_exchange := ecdh_rsa, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA; - -suite({ecdhe_rsa, null, sha}) -> +suite(#{key_exchange := ecdhe_rsa, + cipher := null, + mac := sha}) -> ?TLS_ECDHE_RSA_WITH_NULL_SHA; -suite({ecdhe_rsa, rc4_128, sha}) -> +suite(#{key_exchange := ecdhe_rsa, + cipher := rc4_128, + mac := sha}) -> ?TLS_ECDHE_RSA_WITH_RC4_128_SHA; -suite({ecdhe_rsa, '3des_ede_cbc', sha}) -> +suite(#{key_exchange := ecdhe_rsa, + cipher := '3des_ede_cbc', + mac := sha}) -> ?TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA; -suite({ecdhe_rsa, aes_128_cbc, sha}) -> +suite(#{key_exchange := ecdhe_rsa, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA; -suite({ecdhe_rsa, aes_256_cbc, sha}) -> +suite(#{key_exchange := ecdhe_rsa, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA; - -suite({ecdh_anon, null, sha}) -> +suite(#{key_exchange := ecdh_anon, + cipher := null, + mac := sha}) -> ?TLS_ECDH_anon_WITH_NULL_SHA; -suite({ecdh_anon, rc4_128, sha}) -> +suite(#{key_exchange := ecdh_anon, + cipher := rc4_128, + mac := sha}) -> ?TLS_ECDH_anon_WITH_RC4_128_SHA; -suite({ecdh_anon, '3des_ede_cbc', sha}) -> +suite(#{key_exchange := ecdh_anon, + cipher := '3des_ede_cbc', + mac := sha}) -> ?TLS_ECDH_anon_WITH_3DES_EDE_CBC_SHA; -suite({ecdh_anon, aes_128_cbc, sha}) -> +suite(#{key_exchange := ecdh_anon, + cipher := aes_128_cbc, + mac := sha}) -> ?TLS_ECDH_anon_WITH_AES_128_CBC_SHA; -suite({ecdh_anon, aes_256_cbc, sha}) -> +suite(#{key_exchange := ecdh_anon, + cipher := aes_256_cbc, + mac := sha}) -> ?TLS_ECDH_anon_WITH_AES_256_CBC_SHA; - %%% RFC 5289 EC TLS suites -suite({ecdhe_ecdsa, aes_128_cbc, sha256, sha256}) -> +suite(#{key_exchange := ecdhe_ecdsa, + cipher := aes_128_cbc, + mac:= sha256, + prf := sha256}) -> ?TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256; -suite({ecdhe_ecdsa, aes_256_cbc, sha384, sha384}) -> +suite(#{key_exchange := ecdhe_ecdsa, + cipher := aes_256_cbc, + mac := sha384, + prf := sha384}) -> ?TLS_ECDHE_ECDSA_WITH_AES_256_CBC_SHA384; -suite({ecdh_ecdsa, aes_128_cbc, sha256, sha256}) -> +suite(#{key_exchange := ecdh_ecdsa, + cipher := aes_128_cbc, + mac := sha256, + prf := sha256}) -> ?TLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA256; -suite({ecdh_ecdsa, aes_256_cbc, sha384, sha384}) -> +suite(#{key_exchange := ecdh_ecdsa, + cipher := aes_256_cbc, + mac := sha384, + prf := sha384}) -> ?TLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA384; -suite({ecdhe_rsa, aes_128_cbc, sha256, sha256}) -> +suite(#{key_exchange := ecdhe_rsa, + cipher := aes_128_cbc, + mac := sha256, + prf := sha256}) -> ?TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA256; -suite({ecdhe_rsa, aes_256_cbc, sha384, sha384}) -> +suite(#{key_exchange := ecdhe_rsa, + cipher := aes_256_cbc, + mac := sha384, + prf := sha384}) -> ?TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA384; -suite({ecdh_rsa, aes_128_cbc, sha256, sha256}) -> +suite(#{key_exchange := ecdh_rsa, + cipher := aes_128_cbc, + mac := sha256, + prf := sha256}) -> ?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA256; -suite({ecdh_rsa, aes_256_cbc, sha384, sha384}) -> +suite(#{key_exchange := ecdh_rsa, + cipher := aes_256_cbc, + mac := sha384, + prf := sha384}) -> ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384; - %% RFC 5288 AES-GCM Cipher Suites -suite({rsa, aes_128_gcm, null, sha256}) -> +suite(#{key_exchange := rsa, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> ?TLS_RSA_WITH_AES_128_GCM_SHA256; -suite({rsa, aes_256_gcm, null, sha384}) -> +suite(#{key_exchange := rsa, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> ?TLS_RSA_WITH_AES_256_GCM_SHA384; -suite({dhe_rsa, aes_128_gcm, null, sha256}) -> +suite(#{key_exchange := dhe_rsa, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> ?TLS_DHE_RSA_WITH_AES_128_GCM_SHA256; -suite({dhe_rsa, aes_256_gcm, null, sha384}) -> +suite(#{key_exchange := dhe_rsa, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> ?TLS_DHE_RSA_WITH_AES_256_GCM_SHA384; -suite({dh_rsa, aes_128_gcm, null, sha256}) -> +suite(#{key_exchange := dh_rsa, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> ?TLS_DH_RSA_WITH_AES_128_GCM_SHA256; -suite({dh_rsa, aes_256_gcm, null, sha384}) -> +suite(#{key_exchange := dh_rsa, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> ?TLS_DH_RSA_WITH_AES_256_GCM_SHA384; -suite({dhe_dss, aes_128_gcm, null, sha256}) -> +suite(#{key_exchange := dhe_dss, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> ?TLS_DHE_DSS_WITH_AES_128_GCM_SHA256; -suite({dhe_dss, aes_256_gcm, null, sha384}) -> +suite(#{key_exchange := dhe_dss, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> ?TLS_DHE_DSS_WITH_AES_256_GCM_SHA384; -suite({dh_dss, aes_128_gcm, null, sha256}) -> +suite(#{key_exchange := dh_dss, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> ?TLS_DH_DSS_WITH_AES_128_GCM_SHA256; -suite({dh_dss, aes_256_gcm, null, sha384}) -> +suite(#{key_exchange := dh_dss, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> ?TLS_DH_DSS_WITH_AES_256_GCM_SHA384; -suite({dh_anon, aes_128_gcm, null, sha256}) -> +suite(#{key_exchange := dh_anon, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> ?TLS_DH_anon_WITH_AES_128_GCM_SHA256; -suite({dh_anon, aes_256_gcm, null, sha384}) -> +suite(#{key_exchange := dh_anon, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> ?TLS_DH_anon_WITH_AES_256_GCM_SHA384; - %% RFC 5289 ECC AES-GCM Cipher Suites -suite({ecdhe_ecdsa, aes_128_gcm, null, sha256}) -> +suite(#{key_exchange := ecdhe_ecdsa, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> ?TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256; -suite({ecdhe_ecdsa, aes_256_gcm, null, sha384}) -> +suite(#{key_exchange := ecdhe_ecdsa, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> ?TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384; -suite({ecdh_ecdsa, aes_128_gcm, null, sha256}) -> +suite(#{key_exchange := ecdh_ecdsa, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> ?TLS_ECDH_ECDSA_WITH_AES_128_GCM_SHA256; -suite({ecdh_ecdsa, aes_256_gcm, null, sha384}) -> +suite(#{key_exchange := ecdh_ecdsa, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> ?TLS_ECDH_ECDSA_WITH_AES_256_GCM_SHA384; -suite({ecdhe_rsa, aes_128_gcm, null, sha256}) -> +suite(#{key_exchange := ecdhe_rsa, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> ?TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256; -suite({ecdhe_rsa, aes_256_gcm, null, sha384}) -> +suite(#{key_exchange := ecdhe_rsa, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> ?TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384; -suite({ecdh_rsa, aes_128_gcm, null, sha256}) -> +suite(#{key_exchange := ecdh_rsa, + cipher := aes_128_gcm, + mac := null, + prf := sha256}) -> ?TLS_ECDH_RSA_WITH_AES_128_GCM_SHA256; -suite({ecdh_rsa, aes_256_gcm, null, sha384}) -> +suite(#{key_exchange := ecdh_rsa, + cipher := aes_256_gcm, + mac := null, + prf := sha384}) -> ?TLS_ECDH_RSA_WITH_AES_256_GCM_SHA384; - - %% draft-agl-tls-chacha20poly1305-04 Chacha20/Poly1305 Suites -suite({ecdhe_rsa, chacha20_poly1305, null, sha256}) -> +suite(#{key_exchange := ecdhe_rsa, + cipher := chacha20_poly1305, + mac := null, + prf := sha256}) -> ?TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256; -suite({ecdhe_ecdsa, chacha20_poly1305, null, sha256}) -> +suite(#{key_exchange := ecdhe_ecdsa, + cipher := chacha20_poly1305, + mac := null, + prf := sha256}) -> ?TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256; -suite({dhe_rsa, chacha20_poly1305, null, sha256}) -> +suite(#{key_exchange := dhe_rsa, + cipher := chacha20_poly1305, + mac := null, + prf := sha256}) -> ?TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256. %%-------------------------------------------------------------------- @@ -1516,14 +2229,13 @@ filter(DerCert, Ciphers) -> %% %% Description: Filter suites for algorithms supported by crypto. %%------------------------------------------------------------------- -filter_suites(Suites = [Value|_]) when is_tuple(Value) -> +filter_suites(Suites = [Value|_]) when is_map(Value) -> Algos = crypto:supports(), Hashs = proplists:get_value(hashs, Algos), - lists:filter(fun({KeyExchange, Cipher, Hash}) -> - is_acceptable_keyexchange(KeyExchange, proplists:get_value(public_keys, Algos)) andalso - is_acceptable_cipher(Cipher, proplists:get_value(ciphers, Algos)) andalso - is_acceptable_hash(Hash, proplists:get_value(hashs, Algos)); - ({KeyExchange, Cipher, Hash, Prf}) -> + lists:filter(fun(#{key_exchange := KeyExchange, + cipher := Cipher, + mac := Hash, + prf := Prf}) -> is_acceptable_keyexchange(KeyExchange, proplists:get_value(public_keys, Algos)) andalso is_acceptable_cipher(Cipher, proplists:get_value(ciphers, Algos)) andalso is_acceptable_hash(Hash, Hashs) andalso @@ -1534,9 +2246,12 @@ filter_suites(Suites) -> Algos = crypto:supports(), Hashs = proplists:get_value(hashs, Algos), lists:filter(fun(Suite) -> - {KeyExchange, Cipher, Hash, Prf} = ssl_cipher:suite_definition(Suite), + #{key_exchange := KeyExchange, + cipher := Cipher, + mac := Hash, + prf := Prf} = suite_definition(Suite), is_acceptable_keyexchange(KeyExchange, proplists:get_value(public_keys, Algos)) andalso - is_acceptable_cipher(Cipher, proplists:get_value(ciphers, Algos)) andalso + is_acceptable_cipher(Cipher, proplists:get_value(ciphers, Algos)) andalso is_acceptable_hash(Hash, Hashs) andalso is_acceptable_prf(Prf, Hashs) end, Suites). @@ -1630,7 +2345,7 @@ calc_mac_hash(Type, Version, MacSecret, SeqNo, Type, Length, PlainFragment). -is_stream_ciphersuite({_, rc4_128, _, _}) -> +is_stream_ciphersuite(#{cipher := rc4_128}) -> true; is_stream_ciphersuite(_) -> false. diff --git a/lib/ssl/src/ssl_config.erl b/lib/ssl/src/ssl_config.erl index e4611995ec..022fb7eac0 100644 --- a/lib/ssl/src/ssl_config.erl +++ b/lib/ssl/src/ssl_config.erl @@ -91,7 +91,15 @@ init_certificates(undefined, #{pem_cache := PemCache} = Config, CertFile, server end; init_certificates(Cert, Config, _, _) -> {ok, Config#{own_certificate => Cert}}. - +init_private_key(_, #{algorithm := Alg} = Key, <<>>, _Password, _Client) when Alg == ecdsa; + Alg == rsa; + Alg == dss -> + case maps:is_key(engine, Key) andalso maps:is_key(key_id, Key) of + true -> + Key; + false -> + throw({key, {invalid_key_id, Key}}) + end; init_private_key(_, undefined, <<>>, _Password, _Client) -> undefined; init_private_key(DbHandle, undefined, KeyFile, Password, _) -> diff --git a/lib/ssl/src/ssl_connection.erl b/lib/ssl/src/ssl_connection.erl index d83c9cb59f..d046145dff 100644 --- a/lib/ssl/src/ssl_connection.erl +++ b/lib/ssl/src/ssl_connection.erl @@ -44,33 +44,35 @@ -export([send/2, recv/3, close/2, shutdown/2, new_user/2, get_opts/2, set_opts/2, peer_certificate/1, renegotiation/1, negotiated_protocol/1, prf/5, - get_sslsocket/1, handshake_complete/3, - connection_information/2, handle_common_event/5 + connection_information/2 ]). +%% Alert and close handling +-export([handle_own_alert/4, handle_alert/3, + handle_normal_shutdown/3, stop/2, stop_and_reply/3 + ]). + +%% Data handling +-export([write_application_data/3, read_application_data/2]). + +%% Help functions for tls|dtls_connection.erl +-export([handle_session/7, ssl_config/3, + prepare_connection/2, hibernate_after/3]). + %% General gen_statem state functions with extra callback argument %% to determine if it is an SSL/TLS or DTLS gen_statem machine --export([init/4, hello/4, abbreviated/4, certify/4, cipher/4, +-export([init/4, error/4, hello/4, abbreviated/4, certify/4, cipher/4, connection/4, death_row/4, downgrade/4]). %% gen_statem callbacks -export([terminate/3, format_status/2]). -%% --export([handle_info/3, handle_call/5, handle_session/7, ssl_config/3, - prepare_connection/2, hibernate_after/3]). - -%% Alert and close handling --export([handle_own_alert/4,handle_alert/3, - handle_normal_shutdown/3 - ]). - -%% Data handling --export([write_application_data/3, read_application_data/2]). +%% Erlang Distribution export +-export([get_sslsocket/1, handshake_complete/3]). %%==================================================================== -%% Internal application API -%%==================================================================== +%% Setup +%%==================================================================== %%-------------------------------------------------------------------- -spec connect(tls_connection | dtls_connection, host(), inet:port_number(), @@ -166,6 +168,16 @@ socket_control(dtls_connection = Connection, {_, Socket}, Pid, Transport, Listen {error, Reason} -> {error, Reason} end. + +start_or_recv_cancel_timer(infinity, _RecvFrom) -> + undefined; +start_or_recv_cancel_timer(Timeout, RecvFrom) -> + erlang:send_after(Timeout, self(), {cancel_start_or_recv, RecvFrom}). + +%%==================================================================== +%% User events +%%==================================================================== + %%-------------------------------------------------------------------- -spec send(pid(), iodata()) -> ok | {error, reason()}. %% @@ -281,6 +293,197 @@ handshake_complete(ConnectionPid, Node, DHandle) -> prf(ConnectionPid, Secret, Label, Seed, WantedLength) -> call(ConnectionPid, {prf, Secret, Label, Seed, WantedLength}). +%%==================================================================== +%% Alert and close handling +%%==================================================================== +handle_own_alert(Alert, Version, StateName, + #state{role = Role, + transport_cb = Transport, + socket = Socket, + protocol_cb = Connection, + connection_states = ConnectionStates, + ssl_options = SslOpts} = State) -> + try %% Try to tell the other side + {BinMsg, _} = + Connection:encode_alert(Alert, Version, ConnectionStates), + Connection:send(Transport, Socket, BinMsg) + catch _:_ -> %% Can crash if we are in a uninitialized state + ignore + end, + try %% Try to tell the local user + log_alert(SslOpts#ssl_options.log_alert, Role, Connection:protocol_name(), StateName, Alert#alert{role = Role}), + handle_normal_shutdown(Alert,StateName, State) + catch _:_ -> + ok + end, + stop({shutdown, own_alert}, State). + +handle_normal_shutdown(Alert, _, #state{socket = Socket, + transport_cb = Transport, + protocol_cb = Connection, + start_or_recv_from = StartFrom, + tracker = Tracker, + role = Role, renegotiation = {false, first}}) -> + alert_user(Transport, Tracker,Socket, StartFrom, Alert, Role, Connection); + +handle_normal_shutdown(Alert, StateName, #state{socket = Socket, + socket_options = Opts, + transport_cb = Transport, + protocol_cb = Connection, + user_application = {_Mon, Pid}, + tracker = Tracker, + start_or_recv_from = RecvFrom, role = Role}) -> + alert_user(Transport, Tracker, Socket, StateName, Opts, Pid, RecvFrom, Alert, Role, Connection). + +handle_alert(#alert{level = ?FATAL} = Alert, StateName, + #state{socket = Socket, transport_cb = Transport, + protocol_cb = Connection, + ssl_options = SslOpts, start_or_recv_from = From, host = Host, + port = Port, session = Session, user_application = {_Mon, Pid}, + role = Role, socket_options = Opts, tracker = Tracker} = State) -> + invalidate_session(Role, Host, Port, Session), + log_alert(SslOpts#ssl_options.log_alert, Role, Connection:protocol_name(), + StateName, Alert#alert{role = opposite_role(Role)}), + alert_user(Transport, Tracker, Socket, StateName, Opts, Pid, From, Alert, Role, Connection), + stop(normal, State); + +handle_alert(#alert{level = ?WARNING, description = ?CLOSE_NOTIFY} = Alert, + StateName, State) -> + handle_normal_shutdown(Alert, StateName, State), + stop({shutdown, peer_close}, State); + +handle_alert(#alert{level = ?WARNING, description = ?NO_RENEGOTIATION} = Alert, StateName, + #state{role = Role, ssl_options = SslOpts, protocol_cb = Connection, renegotiation = {true, internal}} = State) -> + log_alert(SslOpts#ssl_options.log_alert, Role, + Connection:protocol_name(), StateName, Alert#alert{role = opposite_role(Role)}), + handle_normal_shutdown(Alert, StateName, State), + stop({shutdown, peer_close}, State); + +handle_alert(#alert{level = ?WARNING, description = ?NO_RENEGOTIATION} = Alert, StateName, + #state{role = Role, + ssl_options = SslOpts, renegotiation = {true, From}, + protocol_cb = Connection} = State0) -> + log_alert(SslOpts#ssl_options.log_alert, Role, + Connection:protocol_name(), StateName, Alert#alert{role = opposite_role(Role)}), + gen_statem:reply(From, {error, renegotiation_rejected}), + {Record, State1} = Connection:next_record(State0), + %% Go back to connection! + State = Connection:reinit_handshake_data(State1#state{renegotiation = undefined}), + Connection:next_event(connection, Record, State); + +%% Gracefully log and ignore all other warning alerts +handle_alert(#alert{level = ?WARNING} = Alert, StateName, + #state{ssl_options = SslOpts, protocol_cb = Connection, role = Role} = State0) -> + log_alert(SslOpts#ssl_options.log_alert, Role, + Connection:protocol_name(), StateName, Alert#alert{role = opposite_role(Role)}), + {Record, State} = Connection:next_record(State0), + Connection:next_event(StateName, Record, State). + +%%==================================================================== +%% Data handling +%%==================================================================== +write_application_data(Data0, {FromPid, _} = From, + #state{socket = Socket, + negotiated_version = Version, + protocol_cb = Connection, + transport_cb = Transport, + connection_states = ConnectionStates0, + socket_options = SockOpts, + ssl_options = #ssl_options{renegotiate_at = RenegotiateAt}} = State) -> + Data = encode_packet(Data0, SockOpts), + + case time_to_renegotiate(Data, ConnectionStates0, RenegotiateAt) of + true -> + Connection:renegotiate(State#state{renegotiation = {true, internal}}, + [{next_event, {call, From}, {application_data, Data0}}]); + false -> + {Msgs, ConnectionStates} = + Connection:encode_data(Data, Version, ConnectionStates0), + NewState = State#state{connection_states = ConnectionStates}, + case Connection:send(Transport, Socket, Msgs) of + ok when FromPid =:= self() -> + hibernate_after(connection, NewState, []); + Error when FromPid =:= self() -> + stop({shutdown, Error}, NewState); + ok -> + hibernate_after(connection, NewState, [{reply, From, ok}]); + Result -> + hibernate_after(connection, NewState, [{reply, From, Result}]) + end + end. + +read_application_data(Data, #state{user_application = {_Mon, Pid}, + socket = Socket, + protocol_cb = Connection, + transport_cb = Transport, + socket_options = SOpts, + bytes_to_read = BytesToRead, + start_or_recv_from = RecvFrom, + timer = Timer, + user_data_buffer = Buffer0, + tracker = Tracker} = State0) -> + Buffer1 = if + Buffer0 =:= <<>> -> Data; + Data =:= <<>> -> Buffer0; + true -> <<Buffer0/binary, Data/binary>> + end, + case get_data(SOpts, BytesToRead, Buffer1) of + {ok, ClientData, Buffer} -> % Send data + case State0 of + #state{ + ssl_options = #ssl_options{erl_dist = true}, + protocol_specific = #{d_handle := DHandle}} -> + State = + State0#state{ + user_data_buffer = Buffer, + bytes_to_read = undefined}, + try erlang:dist_ctrl_put_data(DHandle, ClientData) of + _ + when SOpts#socket_options.active =:= false; + Buffer =:= <<>> -> + %% Passive mode, wait for active once or recv + %% Active and empty, get more data + Connection:next_record_if_active(State); + _ -> %% We have more data + read_application_data(<<>>, State) + catch error:_ -> + death_row(State, disconnect) + end; + _ -> + SocketOpt = + deliver_app_data( + Transport, Socket, SOpts, + ClientData, Pid, RecvFrom, Tracker, Connection), + cancel_timer(Timer), + State = + State0#state{ + user_data_buffer = Buffer, + start_or_recv_from = undefined, + timer = undefined, + bytes_to_read = undefined, + socket_options = SocketOpt + }, + if + SocketOpt#socket_options.active =:= false; + Buffer =:= <<>> -> + %% Passive mode, wait for active once or recv + %% Active and empty, get more data + Connection:next_record_if_active(State); + true -> %% We have more data + read_application_data(<<>>, State) + end + end; + {more, Buffer} -> % no reply, we need more data + Connection:next_record(State0#state{user_data_buffer = Buffer}); + {passive, Buffer} -> + Connection:next_record_if_active(State0#state{user_data_buffer = Buffer}); + {error,_Reason} -> %% Invalid packet in packet mode + deliver_packet_error(Transport, Socket, SOpts, Buffer1, Pid, RecvFrom, Tracker, Connection), + stop(normal, State0) + end. +%%==================================================================== +%% Help functions for tls|dtls_connection.erl +%%==================================================================== %%-------------------------------------------------------------------- -spec handle_session(#server_hello{}, ssl_record:ssl_version(), binary(), ssl_record:connection_states(), _,_, #state{}) -> @@ -292,7 +495,7 @@ handle_session(#server_hello{cipher_suite = CipherSuite, #state{session = #session{session_id = OldId}, negotiated_version = ReqVersion, negotiated_protocol = CurrentProtocol} = State0) -> - {KeyAlgorithm, _, _, _} = + #{key_exchange := KeyAlgorithm} = ssl_cipher:suite_definition(CipherSuite), PremasterSecret = make_premaster_secret(ReqVersion, KeyAlgorithm), @@ -349,7 +552,7 @@ ssl_config(Opts, Role, State) -> ssl_options = Opts}. %%==================================================================== -%% gen_statem state functions +%% gen_statem general state functions with connection cb argument %%==================================================================== %%-------------------------------------------------------------------- -spec init(gen_statem:event_type(), @@ -378,7 +581,7 @@ init({call, From}, {start, {Opts, EmOpts}, Timeout}, init({call, From}, {start, Timeout}, State#state{ssl_options = SslOpts, socket_options = new_emulated(EmOpts, SockOpts)}, Connection) catch throw:Error -> - {stop_and_reply, normal, {reply, From, {error, Error}}} + stop_and_reply(normal, {reply, From, {error, Error}}, State0) end; init({call, From}, Msg, State, Connection) -> handle_call(Msg, From, ?FUNCTION_NAME, State, Connection); @@ -386,6 +589,15 @@ init(_Type, _Event, _State, _Connection) -> {keep_state_and_data, [postpone]}. %%-------------------------------------------------------------------- +-spec error(gen_statem:event_type(), + {start, timeout()} | term(), #state{}, + tls_connection | dtls_connection) -> + gen_statem:state_function_result(). +%%-------------------------------------------------------------------- +error({call, From}, Msg, State, Connection) -> + handle_call(Msg, From, ?FUNCTION_NAME, State, Connection). + +%%-------------------------------------------------------------------- -spec hello(gen_statem:event_type(), #hello_request{} | #server_hello{} | term(), #state{}, tls_connection | dtls_connection) -> @@ -408,7 +620,6 @@ hello(Type, Msg, State, Connection) -> %%-------------------------------------------------------------------- abbreviated({call, From}, Msg, State, Connection) -> handle_call(Msg, From, ?FUNCTION_NAME, State, Connection); - abbreviated(internal, #finished{verify_data = Data} = Finished, #state{role = server, negotiated_version = Version, @@ -429,7 +640,6 @@ abbreviated(internal, #finished{verify_data = Data} = Finished, #alert{} = Alert -> handle_own_alert(Alert, Version, ?FUNCTION_NAME, State0) end; - abbreviated(internal, #finished{verify_data = Data} = Finished, #state{role = client, tls_handshake_history = Handshake0, session = #session{master_secret = MasterSecret}, @@ -449,7 +659,6 @@ abbreviated(internal, #finished{verify_data = Data} = Finished, #alert{} = Alert -> handle_own_alert(Alert, Version, ?FUNCTION_NAME, State0) end; - %% only allowed to send next_protocol message after change cipher spec %% & before finished message and it is not allowed during renegotiation abbreviated(internal, #next_protocol{selected_protocol = SelectedProtocol}, @@ -490,7 +699,6 @@ certify(internal, #certificate{asn1_certificates = []}, State, _) -> Alert = ?ALERT_REC(?FATAL,?HANDSHAKE_FAILURE), handle_own_alert(Alert, Version, ?FUNCTION_NAME, State); - certify(internal, #certificate{asn1_certificates = []}, #state{role = server, ssl_options = #ssl_options{verify = verify_peer, @@ -499,7 +707,6 @@ certify(internal, #certificate{asn1_certificates = []}, {Record, State} = Connection:next_record(State0#state{client_certificate_requested = false}), Connection:next_event(?FUNCTION_NAME, Record, State); - certify(internal, #certificate{}, #state{role = server, negotiated_version = Version, @@ -507,7 +714,6 @@ certify(internal, #certificate{}, State, _) -> Alert = ?ALERT_REC(?FATAL,?UNEXPECTED_MESSAGE, unrequested_certificate), handle_own_alert(Alert, Version, ?FUNCTION_NAME, State); - certify(internal, #certificate{} = Cert, #state{negotiated_version = Version, role = Role, @@ -524,7 +730,6 @@ certify(internal, #certificate{} = Cert, #alert{} = Alert -> handle_own_alert(Alert, Version, ?FUNCTION_NAME, State) end; - certify(internal, #server_key_exchange{exchange_keys = Keys}, #state{role = client, negotiated_version = Version, key_algorithm = Alg, @@ -557,7 +762,6 @@ certify(internal, #server_key_exchange{exchange_keys = Keys}, Version, ?FUNCTION_NAME, State) end end; - certify(internal, #certificate_request{}, #state{role = client, negotiated_version = Version, key_algorithm = Alg} = State, _) @@ -565,8 +769,7 @@ certify(internal, #certificate_request{}, Alg == psk; Alg == dhe_psk; Alg == ecdhe_psk; Alg == rsa_psk; Alg == srp_dss; Alg == srp_rsa; Alg == srp_anon -> handle_own_alert(?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE), - Version, certify, State); - + Version, ?FUNCTION_NAME, State); certify(internal, #certificate_request{} = CertRequest, #state{session = #session{own_certificate = Cert}, role = client, @@ -580,7 +783,6 @@ certify(internal, #certificate_request{} = CertRequest, Connection:next_event(?FUNCTION_NAME, Record, State#state{cert_hashsign_algorithm = NegotiatedHashSign}) end; - %% PSK and RSA_PSK might bypass the Server-Key-Exchange certify(internal, #server_hello_done{}, #state{session = #session{master_secret = undefined}, @@ -599,7 +801,6 @@ certify(internal, #server_hello_done{}, State0#state{premaster_secret = PremasterSecret}), client_certify_and_key_exchange(State, Connection) end; - certify(internal, #server_hello_done{}, #state{session = #session{master_secret = undefined}, ssl_options = #ssl_options{user_lookup_fun = PSKLookup}, @@ -620,7 +821,6 @@ certify(internal, #server_hello_done{}, State0#state{premaster_secret = RSAPremasterSecret}), client_certify_and_key_exchange(State, Connection) end; - %% Master secret was determined with help of server-key exchange msg certify(internal, #server_hello_done{}, #state{session = #session{master_secret = MasterSecret} = Session, @@ -636,7 +836,6 @@ certify(internal, #server_hello_done{}, #alert{} = Alert -> handle_own_alert(Alert, Version, ?FUNCTION_NAME, State0) end; - %% Master secret is calculated from premaster_secret certify(internal, #server_hello_done{}, #state{session = Session0, @@ -654,7 +853,6 @@ certify(internal, #server_hello_done{}, #alert{} = Alert -> handle_own_alert(Alert, Version, ?FUNCTION_NAME, State0) end; - certify(internal = Type, #client_key_exchange{} = Msg, #state{role = server, client_certificate_requested = true, @@ -662,7 +860,6 @@ certify(internal = Type, #client_key_exchange{} = Msg, Connection) -> %% We expect a certificate here handle_common_event(Type, Msg, ?FUNCTION_NAME, State, Connection); - certify(internal, #client_key_exchange{exchange_keys = Keys}, State = #state{key_algorithm = KeyAlg, negotiated_version = Version}, Connection) -> try @@ -672,7 +869,6 @@ certify(internal, #client_key_exchange{exchange_keys = Keys}, #alert{} = Alert -> handle_own_alert(Alert, Version, ?FUNCTION_NAME, State) end; - certify(Type, Msg, State, Connection) -> handle_common_event(Type, Msg, ?FUNCTION_NAME, State, Connection). @@ -684,10 +880,8 @@ certify(Type, Msg, State, Connection) -> %%-------------------------------------------------------------------- cipher({call, From}, Msg, State, Connection) -> handle_call(Msg, From, ?FUNCTION_NAME, State, Connection); - cipher(info, Msg, State, _) -> handle_info(Msg, ?FUNCTION_NAME, State); - cipher(internal, #certificate_verify{signature = Signature, hashsign_algorithm = CertHashSign}, #state{role = server, @@ -710,14 +904,12 @@ cipher(internal, #certificate_verify{signature = Signature, #alert{} = Alert -> handle_own_alert(Alert, Version, ?FUNCTION_NAME, State0) end; - %% client must send a next protocol message if we are expecting it cipher(internal, #finished{}, #state{role = server, expecting_next_protocol_negotiation = true, negotiated_protocol = undefined, negotiated_version = Version} = State0, _Connection) -> handle_own_alert(?ALERT_REC(?FATAL,?UNEXPECTED_MESSAGE), Version, ?FUNCTION_NAME, State0); - cipher(internal, #finished{verify_data = Data} = Finished, #state{negotiated_version = Version, host = Host, @@ -740,7 +932,6 @@ cipher(internal, #finished{verify_data = Data} = Finished, #alert{} = Alert -> handle_own_alert(Alert, Version, ?FUNCTION_NAME, State) end; - %% only allowed to send next_protocol message after change cipher spec %% & before finished message and it is not allowed during renegotiation cipher(internal, #next_protocol{selected_protocol = SelectedProtocol}, @@ -775,7 +966,7 @@ connection({call, {FromPid, _} = From}, {application_data, Data}, catch throw:Error -> case self() of FromPid -> - {stop, {shutdown, Error}}; + stop({shutdown, Error}, State); _ -> hibernate_after( ?FUNCTION_NAME, State, [{reply, From, Error}]) @@ -826,8 +1017,8 @@ connection( ProtocolSpecific#{d_handle => DHandle}}, {Record, NewerState} = Connection:next_record_if_active(NewState), Connection:next_event(connection, Record, NewerState, [{reply, From, ok}]) - catch _:Reason -> - death_row(State, Reason) + catch error:_ -> + death_row(State, disconnect) end; connection({call, From}, Msg, State, Connection) -> handle_call(Msg, From, ?FUNCTION_NAME, State, Connection); @@ -839,10 +1030,24 @@ connection( _) -> eat_msgs(Msg), try send_dist_data(?FUNCTION_NAME, State, DHandle, []) - catch _:Reason -> - death_row(State, Reason) + catch error:_ -> + death_row(State, disconnect) end; connection( + info, {send, From, Ref, Data}, + #state{ + ssl_options = #ssl_options{erl_dist = true}, + protocol_specific = #{d_handle := _}}, + _) -> + %% This is for testing only! + %% + %% Needed by some OTP distribution + %% test suites... + From ! {Ref, ok}, + {keep_state_and_data, + [{next_event, {call, {self(), undefined}}, + {application_data, iolist_to_binary(Data)}}]}; +connection( info, tick = Msg, #state{ ssl_options = #ssl_options{erl_dist = true}, @@ -867,20 +1072,22 @@ connection(Type, Msg, State, Connection) -> %% or the socket may die too death_row( info, {'DOWN', MonitorRef, _, _, Reason}, - #state{user_application={MonitorRef,_Pid} = State}, + #state{user_application={MonitorRef,_Pid}}, _) -> - {stop, {shutdown, Reason}, State}; + {stop, {shutdown, Reason}}; death_row( - info, {'EXIT', Socket, Reason}, #state{socket = Socket} = State, _) -> - {stop, {shutdown, Reason}, State}; + info, {'EXIT', Socket, Reason}, #state{socket = Socket}, _) -> + {stop, {shutdown, Reason}}; death_row(state_timeout, Reason, _State, _Connection) -> {stop, {shutdown,Reason}}; -death_row(_Type, _Msg, State, _Connection) -> - {keep_state, State, [postpone]}. +death_row(_Type, _Msg, _State, _Connection) -> + %% Waste all other events + keep_state_and_data. %% State entry function death_row(State, Reason) -> - {next_state, death_row, State, [{state_timeout, 5000, Reason}]}. + {next_state, death_row, State, + [{state_timeout, 5000, Reason}]}. %%-------------------------------------------------------------------- -spec downgrade(gen_statem:event_type(), term(), @@ -893,10 +1100,10 @@ downgrade(internal, #alert{description = ?CLOSE_NOTIFY}, tls_socket:setopts(Transport, Socket, [{active, false}, {packet, 0}, {mode, binary}]), Transport:controlling_process(Socket, Pid), gen_statem:reply(From, {ok, Socket}), - stop_normal(State); + stop(normal, State); downgrade(timeout, downgrade, #state{downgrade = {_, From}} = State, _) -> gen_statem:reply(From, {error, timeout}), - stop_normal(State); + stop(normal, State); downgrade(Type, Event, State, Connection) -> handle_common_event(Type, Event, ?FUNCTION_NAME, State, Connection). @@ -911,7 +1118,7 @@ handle_common_event(internal, {handshake, {#hello_request{} = Handshake, _}}, co handle_common_event(internal, {handshake, {#hello_request{}, _}}, StateName, #state{role = client}, _) when StateName =/= connection -> {keep_state_and_data}; -handle_common_event(internal, {handshake, {Handshake, Raw}}, StateName, +handle_common_event(internal, {handshake, {Handshake, Raw}}, StateName, #state{tls_handshake_history = Hs0, ssl_options = #ssl_options{v2_hello_compatible = V2HComp}} = State0, Connection) -> @@ -930,8 +1137,8 @@ handle_common_event(timeout, hibernate, _, _, _) -> {keep_state_and_data, [hibernate]}; handle_common_event(internal, {application_data, Data}, StateName, State0, Connection) -> case read_application_data(Data, State0) of - {stop, Reason, State} -> - {stop, Reason, State}; + {stop, _, _} = Stop-> + Stop; {Record, State} -> Connection:next_event(StateName, Record, State) end; @@ -960,8 +1167,9 @@ handle_call({close, _} = Close, From, StateName, State, Connection) -> %% Run terminate before returning so that the reuseaddr %% inet-option works properly Result = Connection:terminate(Close, StateName, State#state{terminated = true}), - {stop_and_reply, {shutdown, normal}, - {reply, From, Result}, State}; + stop_and_reply( + {shutdown, normal}, + {reply, From, Result}, State); handle_call({shutdown, How0}, From, _, #state{transport_cb = Transport, negotiated_version = Version, @@ -982,7 +1190,7 @@ handle_call({shutdown, How0}, From, _, {keep_state_and_data, [{reply, From, ok}]}; Error -> gen_statem:reply(From, {error, Error}), - stop_normal(State) + stop(normal, State) end; handle_call({recv, _N, _Timeout}, From, _, #state{socket_options = @@ -1062,43 +1270,55 @@ handle_info({ErrorTag, Socket, econnaborted}, StateName, tracker = Tracker} = State) when StateName =/= connection -> alert_user(Transport, Tracker,Socket, StartFrom, ?ALERT_REC(?FATAL, ?CLOSE_NOTIFY), Role, Connection), - stop_normal(State); + stop(normal, State); handle_info({ErrorTag, Socket, Reason}, StateName, #state{socket = Socket, error_tag = ErrorTag} = State) -> Report = io_lib:format("SSL: Socket error: ~p ~n", [Reason]), error_logger:error_report(Report), handle_normal_shutdown(?ALERT_REC(?FATAL, ?CLOSE_NOTIFY), StateName, State), - stop_normal(State); + stop(normal, State); handle_info( + {'DOWN', MonitorRef, _, _, Reason}, _, + #state{ + user_application = {MonitorRef, _Pid}, + ssl_options = #ssl_options{erl_dist = true}}) -> + {stop, {shutdown, Reason}}; +handle_info( {'DOWN', MonitorRef, _, _, _}, _, - #state{user_application={MonitorRef,_Pid}} = State) -> - stop_normal(State); + #state{user_application = {MonitorRef, _Pid}}) -> + {stop, normal}; +handle_info( + {'EXIT', Pid, _Reason}, StateName, + #state{user_application = {_MonitorRef, Pid}} = State) -> + %% It seems the user application has linked to us + %% - ignore that and let the monitor handle this + {next_state, StateName, State}; %%% So that terminate will be run when supervisor issues shutdown handle_info({'EXIT', _Sup, shutdown}, _StateName, State) -> - {stop, shutdown, State}; + stop(shutdown, State); handle_info({'EXIT', Socket, normal}, _StateName, #state{socket = Socket} = State) -> %% Handle as transport close" - {stop, {shutdown, transport_closed}, State}; + stop({shutdown, transport_closed}, State); handle_info({'EXIT', Socket, Reason}, _StateName, #state{socket = Socket} = State) -> - {stop, {shutdown, Reason}, State}; + stop({shutdown, Reason}, State); handle_info(allow_renegotiate, StateName, State) -> {next_state, StateName, State#state{allow_renegotiate = true}}; handle_info({cancel_start_or_recv, StartFrom}, StateName, #state{renegotiation = {false, first}} = State) when StateName =/= connection -> - {stop_and_reply, {shutdown, user_timeout}, - {reply, StartFrom, {error, timeout}}, State#state{timer = undefined}}; - + stop_and_reply( + {shutdown, user_timeout}, + {reply, StartFrom, {error, timeout}}, + State#state{timer = undefined}); handle_info({cancel_start_or_recv, RecvFrom}, StateName, #state{start_or_recv_from = RecvFrom} = State) when RecvFrom =/= undefined -> {next_state, StateName, State#state{start_or_recv_from = undefined, bytes_to_read = undefined, timer = undefined}, [{reply, RecvFrom, {error, timeout}}]}; - handle_info({cancel_start_or_recv, _RecvFrom}, StateName, State) -> {next_state, StateName, State#state{timer = undefined}}; @@ -1107,41 +1327,9 @@ handle_info(Msg, StateName, #state{socket = Socket, error_tag = Tag} = State) -> error_logger:info_report(Report), {next_state, StateName, State}. - - -send_dist_data(StateName, State, DHandle, Acc) -> - case erlang:dist_ctrl_get_data(DHandle) of - none -> - erlang:dist_ctrl_get_data_notification(DHandle), - hibernate_after(StateName, State, lists:reverse(Acc)); - Data -> - send_dist_data( - StateName, State, DHandle, - [{next_event, {call, {self(), undefined}}, {application_data, Data}} - |Acc]) - end. - -%% Overload mitigation -eat_msgs(Msg) -> - receive Msg -> eat_msgs(Msg) - after 0 -> ok - end. - -%% When running with erl_dist the stop reason 'normal' -%% would be too silent and prevent cleanup -stop_normal(State) -> - Reason = - case State of - #state{ssl_options = #ssl_options{erl_dist = true}} -> - {shutdown, normal}; - _ -> - normal - end, - {stop, Reason, State}. - -%%-------------------------------------------------------------------- -%% gen_statem callbacks -%%-------------------------------------------------------------------- +%%==================================================================== +%% general gen_statem callbacks +%%==================================================================== terminate(_, _, #state{terminated = true}) -> %% Happens when user closes the connection using ssl:close/1 %% we want to guarantee that Transport:close has been called @@ -1150,7 +1338,6 @@ terminate(_, _, #state{terminated = true}) -> %% returning. In both cases terminate has been run manually %% before run by gen_statem which will end up here ok; - terminate({shutdown, transport_closed} = Reason, _StateName, #state{protocol_cb = Connection, socket = Socket, transport_cb = Transport} = State) -> @@ -1177,7 +1364,6 @@ terminate(Reason, connection, #state{negotiated_version = Version, {BinAlert, ConnectionStates} = terminate_alert(Reason, Version, ConnectionStates0, Connection), Connection:send(Transport, Socket, BinAlert), Connection:close(Reason, Socket, Transport, ConnectionStates, Check); - terminate(Reason, _StateName, #state{transport_cb = Transport, protocol_cb = Connection, socket = Socket } = State) -> @@ -1211,155 +1397,6 @@ format_status(terminate, [_, StateName, State]) -> }}]}]. %%-------------------------------------------------------------------- -%%% -%%-------------------------------------------------------------------- -write_application_data(Data0, {FromPid, _} = From, - #state{socket = Socket, - negotiated_version = Version, - protocol_cb = Connection, - transport_cb = Transport, - connection_states = ConnectionStates0, - socket_options = SockOpts, - ssl_options = #ssl_options{renegotiate_at = RenegotiateAt}} = State) -> - Data = encode_packet(Data0, SockOpts), - - case time_to_renegotiate(Data, ConnectionStates0, RenegotiateAt) of - true -> - Connection:renegotiate(State#state{renegotiation = {true, internal}}, - [{next_event, {call, From}, {application_data, Data0}}]); - false -> - {Msgs, ConnectionStates} = - Connection:encode_data(Data, Version, ConnectionStates0), - NewState = State#state{connection_states = ConnectionStates}, - case Connection:send(Transport, Socket, Msgs) of - ok when FromPid =:= self() -> - hibernate_after(connection, NewState, []); - Error when FromPid =:= self() -> - {stop, {shutdown, Error}, NewState}; - ok -> - hibernate_after(connection, NewState, [{reply, From, ok}]); - Result -> - hibernate_after(connection, NewState, [{reply, From, Result}]) - end - end. - -read_application_data(Data, #state{user_application = {_Mon, Pid}, - socket = Socket, - protocol_cb = Connection, - transport_cb = Transport, - socket_options = SOpts, - bytes_to_read = BytesToRead, - start_or_recv_from = RecvFrom, - timer = Timer, - user_data_buffer = Buffer0, - tracker = Tracker} = State0) -> - Buffer1 = if - Buffer0 =:= <<>> -> Data; - Data =:= <<>> -> Buffer0; - true -> <<Buffer0/binary, Data/binary>> - end, - case get_data(SOpts, BytesToRead, Buffer1) of - {ok, ClientData, Buffer} -> % Send data - case State0 of - #state{ - ssl_options = #ssl_options{erl_dist = true}, - protocol_specific = #{d_handle := DHandle}} -> - State = - State0#state{ - user_data_buffer = Buffer, - bytes_to_read = undefined}, - try erlang:dist_ctrl_put_data(DHandle, ClientData) of - _ - when SOpts#socket_options.active =:= false; - Buffer =:= <<>> -> - %% Passive mode, wait for active once or recv - %% Active and empty, get more data - Connection:next_record_if_active(State); - _ -> %% We have more data - read_application_data(<<>>, State) - catch _:Reason -> - death_row(State, Reason) - end; - _ -> - SocketOpt = - deliver_app_data( - Transport, Socket, SOpts, - ClientData, Pid, RecvFrom, Tracker, Connection), - cancel_timer(Timer), - State = - State0#state{ - user_data_buffer = Buffer, - start_or_recv_from = undefined, - timer = undefined, - bytes_to_read = undefined, - socket_options = SocketOpt - }, - if - SocketOpt#socket_options.active =:= false; - Buffer =:= <<>> -> - %% Passive mode, wait for active once or recv - %% Active and empty, get more data - Connection:next_record_if_active(State); - true -> %% We have more data - read_application_data(<<>>, State) - end - end; - {more, Buffer} -> % no reply, we need more data - Connection:next_record(State0#state{user_data_buffer = Buffer}); - {passive, Buffer} -> - Connection:next_record_if_active(State0#state{user_data_buffer = Buffer}); - {error,_Reason} -> %% Invalid packet in packet mode - deliver_packet_error(Transport, Socket, SOpts, Buffer1, Pid, RecvFrom, Tracker, Connection), - stop_normal(State0) - end. -%%-------------------------------------------------------------------- -%%% -%%-------------------------------------------------------------------- -handle_alert(#alert{level = ?FATAL} = Alert, StateName, - #state{socket = Socket, transport_cb = Transport, - protocol_cb = Connection, - ssl_options = SslOpts, start_or_recv_from = From, host = Host, - port = Port, session = Session, user_application = {_Mon, Pid}, - role = Role, socket_options = Opts, tracker = Tracker} = State) -> - invalidate_session(Role, Host, Port, Session), - log_alert(SslOpts#ssl_options.log_alert, Role, Connection:protocol_name(), - StateName, Alert#alert{role = opposite_role(Role)}), - alert_user(Transport, Tracker, Socket, StateName, Opts, Pid, From, Alert, Role, Connection), - stop_normal(State); - -handle_alert(#alert{level = ?WARNING, description = ?CLOSE_NOTIFY} = Alert, - StateName, State) -> - handle_normal_shutdown(Alert, StateName, State), - {stop, {shutdown, peer_close}}; - -handle_alert(#alert{level = ?WARNING, description = ?NO_RENEGOTIATION} = Alert, StateName, - #state{role = Role, ssl_options = SslOpts, protocol_cb = Connection, renegotiation = {true, internal}} = State) -> - log_alert(SslOpts#ssl_options.log_alert, Role, - Connection:protocol_name(), StateName, Alert#alert{role = opposite_role(Role)}), - handle_normal_shutdown(Alert, StateName, State), - {stop, {shutdown, peer_close}}; - -handle_alert(#alert{level = ?WARNING, description = ?NO_RENEGOTIATION} = Alert, StateName, - #state{role = Role, - ssl_options = SslOpts, renegotiation = {true, From}, - protocol_cb = Connection} = State0) -> - log_alert(SslOpts#ssl_options.log_alert, Role, - Connection:protocol_name(), StateName, Alert#alert{role = opposite_role(Role)}), - gen_statem:reply(From, {error, renegotiation_rejected}), - {Record, State1} = Connection:next_record(State0), - %% Go back to connection! - State = Connection:reinit_handshake_data(State1#state{renegotiation = undefined}), - Connection:next_event(connection, Record, State); - -%% Gracefully log and ignore all other warning alerts -handle_alert(#alert{level = ?WARNING} = Alert, StateName, - #state{ssl_options = SslOpts, protocol_cb = Connection, role = Role} = State0) -> - log_alert(SslOpts#ssl_options.log_alert, Role, - Connection:protocol_name(), StateName, Alert#alert{role = opposite_role(Role)}), - {Record, State} = Connection:next_record(State0), - Connection:next_event(StateName, Record, State). - -%%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- connection_info(#state{sni_hostname = SNIHostname, @@ -1369,9 +1406,9 @@ connection_info(#state{sni_hostname = SNIHostname, negotiated_version = {_,_} = Version, ssl_options = Opts}) -> RecordCB = record_cb(Connection), - CipherSuiteDef = ssl_cipher:erl_suite_definition(CipherSuite), - IsNamedCurveSuite = lists:member(element(1,CipherSuiteDef), - [ecdh_ecdsa, ecdhe_ecdsa, ecdh_anon]), + CipherSuiteDef = #{key_exchange := KexAlg} = ssl_cipher:suite_definition(CipherSuite), + IsNamedCurveSuite = lists:member(KexAlg, + [ecdh_ecdsa, ecdhe_ecdsa, ecdh_anon]), CurveInfo = case ECCCurve of {namedCurve, Curve} when IsNamedCurveSuite -> [{ecc, {named_curve, pubkey_cert_records:namedCurves(Curve)}}]; @@ -1380,7 +1417,7 @@ connection_info(#state{sni_hostname = SNIHostname, end, [{protocol, RecordCB:protocol_version(Version)}, {session_id, SessionId}, - {cipher_suite, CipherSuiteDef}, + {cipher_suite, ssl_cipher:erl_suite_definition(CipherSuiteDef)}, {sni_hostname, SNIHostname} | CurveInfo] ++ ssl_options_list(Opts). security_info(#state{connection_states = ConnectionStates}) -> @@ -1448,7 +1485,7 @@ resumed_server_hello(#state{session = Session, server_hello(ServerHello, State0, Connection) -> CipherSuite = ServerHello#server_hello.cipher_suite, - {KeyAlgorithm, _, _, _} = ssl_cipher:suite_definition(CipherSuite), + #{key_exchange := KeyAlgorithm} = ssl_cipher:suite_definition(CipherSuite), State = Connection:queue_handshake(ServerHello, State0), State#state{key_algorithm = KeyAlgorithm}. @@ -1462,8 +1499,8 @@ handle_peer_cert(Role, PeerCert, PublicKeyInfo, State1 = State0#state{session = Session#session{peer_certificate = PeerCert}, public_key_info = PublicKeyInfo}, - {KeyAlg,_,_,_} = ssl_cipher:suite_definition(CipherSuite), - State2 = handle_peer_cert_key(Role, PeerCert, PublicKeyInfo, KeyAlg, State1), + #{key_exchange := KeyAlgorithm} = ssl_cipher:suite_definition(CipherSuite), + State2 = handle_peer_cert_key(Role, PeerCert, PublicKeyInfo, KeyAlgorithm, State1), {Record, State} = Connection:next_record(State2), Connection:next_event(certify, Record, State). @@ -1476,7 +1513,6 @@ handle_peer_cert_key(client, _, ECDHKey = public_key:generate_key(PublicKeyParams), PremasterSecret = ssl_handshake:premaster_secret(PublicKey, ECDHKey), master_secret(PremasterSecret, State#state{diffie_hellman_keys = ECDHKey}); - %% We do currently not support cipher suites that use fixed DH. %% If we want to implement that the following clause can be used %% to extract DH parameters form cert. @@ -1496,7 +1532,6 @@ certify_client(#state{client_certificate_requested = true, role = client, = State, Connection) -> Certificate = ssl_handshake:certificate(OwnCert, CertDbHandle, CertDbRef, client), Connection:queue_handshake(Certificate, State); - certify_client(#state{client_certificate_requested = false} = State, _) -> State. @@ -1546,10 +1581,26 @@ server_certify_and_key_exchange(State0, Connection) -> request_client_cert(State2, Connection). certify_client_key_exchange(#encrypted_premaster_secret{premaster_secret= EncPMS}, - #state{private_key = Key} = State, Connection) -> - PremasterSecret = ssl_handshake:premaster_secret(EncPMS, Key), + #state{private_key = Key, client_hello_version = {Major, Minor} = Version} = State, Connection) -> + FakeSecret = make_premaster_secret(Version, rsa), + %% Countermeasure for Bleichenbacher attack always provide some kind of premaster secret + %% and fail handshake later.RFC 5246 section 7.4.7.1. + PremasterSecret = + try ssl_handshake:premaster_secret(EncPMS, Key) of + Secret when erlang:byte_size(Secret) == ?NUM_OF_PREMASTERSECRET_BYTES -> + case Secret of + <<?BYTE(Major), ?BYTE(Minor), Rest/binary>> -> %% Correct + <<?BYTE(Major), ?BYTE(Minor), Rest/binary>>; + <<?BYTE(_), ?BYTE(_), Rest/binary>> -> %% Version mismatch + <<?BYTE(Major), ?BYTE(Minor), Rest/binary>> + end; + _ -> %% erlang:byte_size(Secret) =/= ?NUM_OF_PREMASTERSECRET_BYTES + FakeSecret + catch + #alert{description = ?DECRYPT_ERROR} -> + FakeSecret + end, calculate_master_secret(PremasterSecret, State, Connection, certify, cipher); - certify_client_key_exchange(#client_diffie_hellman_public{dh_public = ClientPublicDhKey}, #state{diffie_hellman_params = #'DHParameter'{} = Params, diffie_hellman_keys = {_, ServerDhPrivateKey}} = State, @@ -1561,14 +1612,12 @@ certify_client_key_exchange(#client_ec_diffie_hellman_public{dh_public = ClientP #state{diffie_hellman_keys = ECDHKey} = State, Connection) -> PremasterSecret = ssl_handshake:premaster_secret(#'ECPoint'{point = ClientPublicEcDhPoint}, ECDHKey), calculate_master_secret(PremasterSecret, State, Connection, certify, cipher); - certify_client_key_exchange(#client_psk_identity{} = ClientKey, #state{ssl_options = #ssl_options{user_lookup_fun = PSKLookup}} = State0, Connection) -> PremasterSecret = ssl_handshake:premaster_secret(ClientKey, PSKLookup), calculate_master_secret(PremasterSecret, State0, Connection, certify, cipher); - certify_client_key_exchange(#client_dhe_psk_identity{} = ClientKey, #state{diffie_hellman_params = #'DHParameter'{} = Params, diffie_hellman_keys = {_, ServerDhPrivateKey}, @@ -1578,7 +1627,6 @@ certify_client_key_exchange(#client_dhe_psk_identity{} = ClientKey, PremasterSecret = ssl_handshake:premaster_secret(ClientKey, ServerDhPrivateKey, Params, PSKLookup), calculate_master_secret(PremasterSecret, State0, Connection, certify, cipher); - certify_client_key_exchange(#client_ecdhe_psk_identity{} = ClientKey, #state{diffie_hellman_keys = ServerEcDhPrivateKey, ssl_options = @@ -1587,7 +1635,6 @@ certify_client_key_exchange(#client_ecdhe_psk_identity{} = ClientKey, PremasterSecret = ssl_handshake:premaster_secret(ClientKey, ServerEcDhPrivateKey, PSKLookup), calculate_master_secret(PremasterSecret, State, Connection, certify, cipher); - certify_client_key_exchange(#client_rsa_psk_identity{} = ClientKey, #state{private_key = Key, ssl_options = @@ -1595,7 +1642,6 @@ certify_client_key_exchange(#client_rsa_psk_identity{} = ClientKey, Connection) -> PremasterSecret = ssl_handshake:premaster_secret(ClientKey, Key, PSKLookup), calculate_master_secret(PremasterSecret, State0, Connection, certify, cipher); - certify_client_key_exchange(#client_srp_public{} = ClientKey, #state{srp_params = Params, srp_keys = Key @@ -1610,7 +1656,6 @@ certify_server(#state{key_algorithm = Algo} = State, _) when Algo == dh_anon; Algo == ecdhe_psk; Algo == srp_anon -> State; - certify_server(#state{cert_db = CertDbHandle, cert_db_ref = CertDbRef, session = #session{own_certificate = OwnCert}} = State, Connection) -> @@ -1644,7 +1689,6 @@ key_exchange(#state{role = server, key_algorithm = Algo, PrivateKey}), State = Connection:queue_handshake(Msg, State0), State#state{diffie_hellman_keys = DHKeys}; - key_exchange(#state{role = server, private_key = Key, key_algorithm = Algo} = State, _) when Algo == ecdh_ecdsa; Algo == ecdh_rsa -> State#state{diffie_hellman_keys = Key}; @@ -1670,7 +1714,6 @@ key_exchange(#state{role = server, key_algorithm = Algo, PrivateKey}), State = Connection:queue_handshake(Msg, State0), State#state{diffie_hellman_keys = ECDHKeys}; - key_exchange(#state{role = server, key_algorithm = psk, ssl_options = #ssl_options{psk_identity = undefined}} = State, _) -> State; @@ -1691,7 +1734,6 @@ key_exchange(#state{role = server, key_algorithm = psk, ServerRandom, PrivateKey}), Connection:queue_handshake(Msg, State0); - key_exchange(#state{role = server, key_algorithm = dhe_psk, ssl_options = #ssl_options{psk_identity = PskIdentityHint}, hashsign_algorithm = HashSignAlgo, @@ -1713,7 +1755,6 @@ key_exchange(#state{role = server, key_algorithm = dhe_psk, PrivateKey}), State = Connection:queue_handshake(Msg, State0), State#state{diffie_hellman_keys = DHKeys}; - key_exchange(#state{role = server, key_algorithm = ecdhe_psk, ssl_options = #ssl_options{psk_identity = PskIdentityHint}, hashsign_algorithm = HashSignAlgo, @@ -1735,7 +1776,6 @@ key_exchange(#state{role = server, key_algorithm = ecdhe_psk, PrivateKey}), State = Connection:queue_handshake(Msg, State0), State#state{diffie_hellman_keys = ECDHKeys}; - key_exchange(#state{role = server, key_algorithm = rsa_psk, ssl_options = #ssl_options{psk_identity = undefined}} = State, _) -> State; @@ -1756,7 +1796,6 @@ key_exchange(#state{role = server, key_algorithm = rsa_psk, ServerRandom, PrivateKey}), Connection:queue_handshake(Msg, State0); - key_exchange(#state{role = server, key_algorithm = Algo, ssl_options = #ssl_options{user_lookup_fun = LookupFun}, hashsign_algorithm = HashSignAlgo, @@ -1787,7 +1826,6 @@ key_exchange(#state{role = server, key_algorithm = Algo, State = Connection:queue_handshake(Msg, State0), State#state{srp_params = SrpParams, srp_keys = Keys}; - key_exchange(#state{role = client, key_algorithm = rsa, public_key_info = PublicKeyInfo, @@ -1795,7 +1833,6 @@ key_exchange(#state{role = client, premaster_secret = PremasterSecret} = State0, Connection) -> Msg = rsa_key_exchange(ssl:tls_version(Version), PremasterSecret, PublicKeyInfo), Connection:queue_handshake(Msg, State0); - key_exchange(#state{role = client, key_algorithm = Algorithm, negotiated_version = Version, @@ -1816,7 +1853,6 @@ key_exchange(#state{role = client, Algorithm == ecdh_anon -> Msg = ssl_handshake:key_exchange(client, ssl:tls_version(Version), {ecdh, Keys}), Connection:queue_handshake(Msg, State0); - key_exchange(#state{role = client, ssl_options = SslOpts, key_algorithm = psk, @@ -1824,7 +1860,6 @@ key_exchange(#state{role = client, Msg = ssl_handshake:key_exchange(client, ssl:tls_version(Version), {psk, SslOpts#ssl_options.psk_identity}), Connection:queue_handshake(Msg, State0); - key_exchange(#state{role = client, ssl_options = SslOpts, key_algorithm = dhe_psk, @@ -1855,7 +1890,6 @@ key_exchange(#state{role = client, Msg = rsa_psk_key_exchange(ssl:tls_version(Version), SslOpts#ssl_options.psk_identity, PremasterSecret, PublicKeyInfo), Connection:queue_handshake(Msg, State0); - key_exchange(#state{role = client, key_algorithm = Algorithm, negotiated_version = Version, @@ -2244,10 +2278,7 @@ set_socket_opts(_,_, _, [{active, _} = Opt| _], SockOpts, _) -> set_socket_opts(ConnectionCb, Transport, Socket, [Opt | Opts], SockOpts, Other) -> set_socket_opts(ConnectionCb, Transport, Socket, Opts, SockOpts, [Opt | Other]). -start_or_recv_cancel_timer(infinity, _RecvFrom) -> - undefined; -start_or_recv_cancel_timer(Timeout, RecvFrom) -> - erlang:send_after(Timeout, self(), {cancel_start_or_recv, RecvFrom}). + hibernate_after(connection = StateName, #state{ssl_options=#ssl_options{hibernate_after = HibernateAfter}} = State, @@ -2426,8 +2457,8 @@ handle_active_option(_, connection = StateName0, To, Reply, #state{protocol_cb = hibernate_after(StateName, State, [{reply, To, Reply}]); {next_state, StateName, State, Actions} -> hibernate_after(StateName, State, [{reply, To, Reply} | Actions]); - {stop, Reason, State} -> - {stop, Reason, State} + {stop, _, _} = Stop -> + Stop end; handle_active_option(_, StateName, To, Reply, #state{user_data_buffer = <<>>} = State) -> %% Active once already set @@ -2436,8 +2467,8 @@ handle_active_option(_, StateName, To, Reply, #state{user_data_buffer = <<>>} = %% user_data_buffer =/= <<>> handle_active_option(_, StateName0, To, Reply, #state{protocol_cb = Connection} = State0) -> case read_application_data(<<>>, State0) of - {stop, Reason, State} -> - {stop, Reason, State}; + {stop, _, _} = Stop -> + Stop; {Record, State1} -> %% Note: Renogotiation may cause StateName0 =/= StateName case Connection:next_event(StateName0, Record, State1) of @@ -2595,7 +2626,8 @@ send_or_reply(_, Pid, _From, Data) -> send_user(Pid, Data). send_user(Pid, Msg) -> - Pid ! Msg. + Pid ! Msg, + ok. alert_user(Transport, Tracker, Socket, connection, Opts, Pid, From, Alert, Role, Connection) -> alert_user(Transport, Tracker, Socket, Opts#socket_options.active, Pid, From, Alert, Role, Connection); @@ -2632,45 +2664,6 @@ log_alert(true, Role, ProtocolName, StateName, Alert) -> log_alert(false, _, _, _, _) -> ok. -handle_own_alert(Alert, Version, StateName, - #state{role = Role, - transport_cb = Transport, - socket = Socket, - protocol_cb = Connection, - connection_states = ConnectionStates, - ssl_options = SslOpts} = State) -> - try %% Try to tell the other side - {BinMsg, _} = - Connection:encode_alert(Alert, Version, ConnectionStates), - Connection:send(Transport, Socket, BinMsg) - catch _:_ -> %% Can crash if we are in a uninitialized state - ignore - end, - try %% Try to tell the local user - log_alert(SslOpts#ssl_options.log_alert, Role, Connection:protocol_name(), StateName, Alert#alert{role = Role}), - handle_normal_shutdown(Alert,StateName, State) - catch _:_ -> - ok - end, - {stop, {shutdown, own_alert}}. - -handle_normal_shutdown(Alert, _, #state{socket = Socket, - transport_cb = Transport, - protocol_cb = Connection, - start_or_recv_from = StartFrom, - tracker = Tracker, - role = Role, renegotiation = {false, first}}) -> - alert_user(Transport, Tracker,Socket, StartFrom, Alert, Role, Connection); - -handle_normal_shutdown(Alert, StateName, #state{socket = Socket, - socket_options = Opts, - transport_cb = Transport, - protocol_cb = Connection, - user_application = {_Mon, Pid}, - tracker = Tracker, - start_or_recv_from = RecvFrom, role = Role}) -> - alert_user(Transport, Tracker, Socket, StateName, Opts, Pid, RecvFrom, Alert, Role, Connection). - invalidate_session(client, Host, Port, Session) -> ssl_manager:invalidate_session(Host, Port, Session); invalidate_session(server, _, Port, Session) -> @@ -2727,3 +2720,42 @@ new_emulated([], EmOpts) -> EmOpts; new_emulated(NewEmOpts, _) -> NewEmOpts. +%%---------------Erlang distribution -------------------------------------- + +send_dist_data(StateName, State, DHandle, Acc) -> + case erlang:dist_ctrl_get_data(DHandle) of + none -> + erlang:dist_ctrl_get_data_notification(DHandle), + hibernate_after(StateName, State, lists:reverse(Acc)); + Data -> + send_dist_data( + StateName, State, DHandle, + [{next_event, {call, {self(), undefined}}, {application_data, Data}} + |Acc]) + end. + +%% Overload mitigation +eat_msgs(Msg) -> + receive Msg -> eat_msgs(Msg) + after 0 -> ok + end. + +%% When acting as distribution controller map the exit reason +%% to follow the documented nodedown_reason for net_kernel +stop(Reason, State) -> + {stop, erl_dist_stop_reason(Reason, State), State}. + +stop_and_reply(Reason, Replies, State) -> + {stop_and_reply, erl_dist_stop_reason(Reason, State), Replies, State}. + +erl_dist_stop_reason( + Reason, #state{ssl_options = #ssl_options{erl_dist = true}}) -> + case Reason of + normal -> + %% We can not exit with normal since that will not bring + %% down the rest of the distribution processes + {shutdown, normal}; + _ -> Reason + end; +erl_dist_stop_reason(Reason, _State) -> + Reason. diff --git a/lib/ssl/src/ssl_connection.hrl b/lib/ssl/src/ssl_connection.hrl index 3e26f67de1..f9d2149170 100644 --- a/lib/ssl/src/ssl_connection.hrl +++ b/lib/ssl/src/ssl_connection.hrl @@ -57,6 +57,7 @@ session_cache_cb :: atom(), crl_db :: term(), negotiated_version :: ssl_record:ssl_version() | 'undefined', + client_hello_version :: ssl_record:ssl_version() | 'undefined', client_certificate_requested = false :: boolean(), key_algorithm :: ssl_cipher:key_algo(), hashsign_algorithm = {undefined, undefined}, diff --git a/lib/ssl/src/ssl_dist_sup.erl b/lib/ssl/src/ssl_dist_sup.erl index c241a9bced..bea67935d8 100644 --- a/lib/ssl/src/ssl_dist_sup.erl +++ b/lib/ssl/src/ssl_dist_sup.erl @@ -30,6 +30,9 @@ %% Supervisor callback -export([init/1]). +%% Debug +-export([consult/1]). + %%%========================================================================= %%% API %%%========================================================================= @@ -37,7 +40,18 @@ -spec start_link() -> {ok, pid()} | ignore | {error, term()}. start_link() -> - supervisor:start_link({local, ?MODULE}, ?MODULE, []). + case init:get_argument(ssl_dist_optfile) of + {ok, [File]} -> + DistOpts = consult(File), + TabOpts = [set, protected, named_table], + Tab = ets:new(ssl_dist_opts, TabOpts), + true = ets:insert(Tab, DistOpts), + supervisor:start_link({local, ?MODULE}, ?MODULE, []); + {ok, BadArg} -> + error({bad_ssl_dist_optfile, BadArg}); + error -> + supervisor:start_link({local, ?MODULE}, ?MODULE, []) + end. %%%========================================================================= %%% Supervisor callback @@ -68,3 +82,52 @@ ssl_connection_sup() -> Modules = [ssl_connection_sup], Type = supervisor, {Name, StartFunc, Restart, Shutdown, Type, Modules}. + +consult(File) -> + case erl_prim_loader:get_file(File) of + {ok, Binary, _FullName} -> + Encoding = + case epp:read_encoding_from_binary(Binary) of + none -> latin1; + Enc -> Enc + end, + case unicode:characters_to_list(Binary, Encoding) of + {error, _String, Rest} -> + error( + {bad_ssl_dist_optfile, {encoding_error, Rest}}); + {incomplete, _String, Rest} -> + error( + {bad_ssl_dist_optfile, {encoding_incomplete, Rest}}); + String when is_list(String) -> + consult_string(String) + end; + error -> + error({bad_ssl_dist_optfile, File}) + end. + +consult_string(String) -> + case erl_scan:string(String) of + {error, Info, Location} -> + error({bad_ssl_dist_optfile, {scan_error, Info, Location}}); + {ok, Tokens, _EndLocation} -> + consult_tokens(Tokens) + end. + +consult_tokens(Tokens) -> + case erl_parse:parse_exprs(Tokens) of + {error, Info} -> + error({bad_ssl_dist_optfile, {parse_error, Info}}); + {ok, [Expr]} -> + consult_expr(Expr); + {ok, Other} -> + error({bad_ssl_dist_optfile, {parse_error, Other}}) + end. + +consult_expr(Expr) -> + {value, Value, Bs} = erl_eval:expr(Expr, erl_eval:new_bindings()), + case erl_eval:bindings(Bs) of + [] -> + Value; + Other -> + error({bad_ssl_dist_optfile, {bindings, Other}}) + end. diff --git a/lib/ssl/src/ssl_handshake.erl b/lib/ssl/src/ssl_handshake.erl index 81d38a38e4..0c55af9174 100644 --- a/lib/ssl/src/ssl_handshake.erl +++ b/lib/ssl/src/ssl_handshake.erl @@ -44,46 +44,44 @@ #client_key_exchange{} | #finished{} | #certificate_verify{} | #hello_request{} | #next_protocol{}. -%% Handshake messages +%% Create handshake messages -export([hello_request/0, server_hello/4, server_hello_done/0, - certificate/4, certificate_request/5, key_exchange/3, + certificate/4, client_certificate_verify/6, certificate_request/5, key_exchange/3, finished/5, next_protocol/1]). %% Handle handshake messages --export([certify/7, client_certificate_verify/6, certificate_verify/6, verify_signature/5, +-export([certify/7, certificate_verify/6, verify_signature/5, master_secret/4, server_key_exchange_hash/2, verify_connection/6, - init_handshake_history/0, update_handshake_history/3, verify_server_key/5 + init_handshake_history/0, update_handshake_history/3, verify_server_key/5, + select_version/3 ]). -%% Encode/Decode +%% Encode -export([encode_handshake/2, encode_hello_extensions/1, - encode_client_protocol_negotiation/2, encode_protocols_advertised_on_server/1, - decode_handshake/3, decode_hello_extensions/1, + encode_client_protocol_negotiation/2, encode_protocols_advertised_on_server/1]). +%% Decode +-export([decode_handshake/3, decode_hello_extensions/1, decode_server_key/3, decode_client_key/3, decode_suites/2 ]). %% Cipher suites handling --export([available_suites/2, available_signature_algs/2, cipher_suites/2, - select_session/11, supported_ecc/1, available_signature_algs/4]). +-export([available_suites/2, available_signature_algs/2, available_signature_algs/4, + cipher_suites/3, prf/6, select_session/11, supported_ecc/1, + premaster_secret/2, premaster_secret/3, premaster_secret/4]). %% Extensions handling -export([client_hello_extensions/5, handle_client_hello_extensions/9, %% Returns server hello extensions - handle_server_hello_extensions/9, select_curve/2, select_curve/3 + handle_server_hello_extensions/9, select_curve/2, select_curve/3, + select_hashsign/4, select_hashsign/5, + select_hashsign_algs/3 ]). -%% MISC --export([select_version/3, prf/6, select_hashsign/4, select_hashsign/5, - select_hashsign_algs/3, - premaster_secret/2, premaster_secret/3, premaster_secret/4]). - %%==================================================================== -%% Internal application API +%% Create handshake messages %%==================================================================== -%% ---------- Create handshake messages ---------- - %%-------------------------------------------------------------------- -spec hello_request() -> #hello_request{}. %% @@ -119,31 +117,6 @@ server_hello(SessionId, Version, ConnectionStates, Extensions) -> server_hello_done() -> #server_hello_done{}. -client_hello_extensions(Version, CipherSuites, - #ssl_options{signature_algs = SupportedHashSigns, - eccs = SupportedECCs} = SslOpts, ConnectionStates, Renegotiation) -> - {EcPointFormats, EllipticCurves} = - case advertises_ec_ciphers(lists:map(fun ssl_cipher:suite_definition/1, CipherSuites)) of - true -> - client_ecc_extensions(SupportedECCs); - false -> - {undefined, undefined} - end, - SRP = srp_user(SslOpts), - - #hello_extensions{ - renegotiation_info = renegotiation_info(tls_record, client, - ConnectionStates, Renegotiation), - srp = SRP, - signature_algs = available_signature_algs(SupportedHashSigns, Version), - ec_point_formats = EcPointFormats, - elliptic_curves = EllipticCurves, - alpn = encode_alpn(SslOpts#ssl_options.alpn_advertised_protocols, Renegotiation), - next_protocol_negotiation = - encode_client_protocol_negotiation(SslOpts#ssl_options.next_protocol_selector, - Renegotiation), - sni = sni(SslOpts#ssl_options.server_name_indication)}. - %%-------------------------------------------------------------------- -spec certificate(der_cert(), db_handle(), certdb_ref(), client | server) -> #certificate{} | #alert{}. %% @@ -171,14 +144,6 @@ certificate(OwnCert, CertDbHandle, CertDbRef, server) -> end. %%-------------------------------------------------------------------- --spec next_protocol(binary()) -> #next_protocol{}. -%% -%% Description: Creates a next protocol message -%%------------------------------------------------------------------- -next_protocol(SelectedProtocol) -> - #next_protocol{selected_protocol = SelectedProtocol}. - -%%-------------------------------------------------------------------- -spec client_certificate_verify(undefined | der_cert(), binary(), ssl_record:ssl_version(), term(), public_key:private_key(), ssl_handshake_history()) -> @@ -346,22 +311,51 @@ key_exchange(server, Version, {srp, {PublicKey, _}, finished(Version, Role, PrfAlgo, MasterSecret, {Handshake, _}) -> % use the current handshake #finished{verify_data = calc_finished(Version, Role, PrfAlgo, MasterSecret, Handshake)}. +%%-------------------------------------------------------------------- +-spec next_protocol(binary()) -> #next_protocol{}. +%% +%% Description: Creates a next protocol message +%%------------------------------------------------------------------- +next_protocol(SelectedProtocol) -> + #next_protocol{selected_protocol = SelectedProtocol}. -%% ---------- Handle handshake messages ---------- +%%==================================================================== +%% Handle handshake messages +%%==================================================================== +%%-------------------------------------------------------------------- +-spec certify(#certificate{}, db_handle(), certdb_ref(), #ssl_options{}, term(), + client | server, inet:hostname() | inet:ip_address()) -> {der_cert(), public_key_info()} | #alert{}. +%% +%% Description: Handles a certificate handshake message +%%-------------------------------------------------------------------- +certify(#certificate{asn1_certificates = ASN1Certs}, CertDbHandle, CertDbRef, + Opts, CRLDbHandle, Role, Host) -> -verify_server_key(#server_key_params{params_bin = EncParams, - signature = Signature}, - HashSign = {HashAlgo, _}, - ConnectionStates, Version, PubKeyInfo) -> - #{security_parameters := SecParams} = - ssl_record:pending_connection_state(ConnectionStates, read), - #security_parameters{client_random = ClientRandom, - server_random = ServerRandom} = SecParams, - Hash = server_key_exchange_hash(HashAlgo, - <<ClientRandom/binary, - ServerRandom/binary, - EncParams/binary>>), - verify_signature(Version, Hash, HashSign, Signature, PubKeyInfo). + ServerName = server_name(Opts#ssl_options.server_name_indication, Host, Role), + [PeerCert | _] = ASN1Certs, + try + {TrustedCert, CertPath} = + ssl_certificate:trusted_cert_and_path(ASN1Certs, CertDbHandle, CertDbRef, + Opts#ssl_options.partial_chain), + ValidationFunAndState = validation_fun_and_state(Opts#ssl_options.verify_fun, Role, + CertDbHandle, CertDbRef, ServerName, + Opts#ssl_options.crl_check, CRLDbHandle, CertPath), + case public_key:pkix_path_validation(TrustedCert, + CertPath, + [{max_path_length, Opts#ssl_options.depth}, + {verify_fun, ValidationFunAndState}]) of + {ok, {PublicKeyInfo,_}} -> + {PeerCert, PublicKeyInfo}; + {error, Reason} -> + path_validation_alert(Reason) + end + catch + error:{badmatch,{asn1, Asn1Reason}} -> + %% ASN-1 decode of certificate somehow failed + ?ALERT_REC(?FATAL, ?CERTIFICATE_UNKNOWN, {failed_to_decode_certificate, Asn1Reason}); + error:OtherReason -> + ?ALERT_REC(?FATAL, ?INTERNAL_ERROR, {unexpected_error, OtherReason}) + end. %%-------------------------------------------------------------------- -spec certificate_verify(binary(), public_key_info(), ssl_record:ssl_version(), term(), @@ -404,43 +398,55 @@ verify_signature(_, Hash, {HashAlgo, _SignAlg}, Signature, {?'id-ecPublicKey', PublicKey, PublicKeyParams}) -> public_key:verify({digest, Hash}, HashAlgo, Signature, {PublicKey, PublicKeyParams}). - %%-------------------------------------------------------------------- --spec certify(#certificate{}, db_handle(), certdb_ref(), #ssl_options{}, term(), - client | server, inet:hostname() | inet:ip_address()) -> {der_cert(), public_key_info()} | #alert{}. +-spec master_secret(ssl_record:ssl_version(), #session{} | binary(), ssl_record:connection_states(), + client | server) -> {binary(), ssl_record:connection_states()} | #alert{}. %% -%% Description: Handles a certificate handshake message -%%-------------------------------------------------------------------- -certify(#certificate{asn1_certificates = ASN1Certs}, CertDbHandle, CertDbRef, - Opts, CRLDbHandle, Role, Host) -> +%% Description: Sets or calculates the master secret and calculate keys, +%% updating the pending connection states. The Mastersecret and the update +%% connection states are returned or an alert if the calculation fails. +%%------------------------------------------------------------------- +master_secret(Version, #session{master_secret = Mastersecret}, + ConnectionStates, Role) -> + #{security_parameters := SecParams} = + ssl_record:pending_connection_state(ConnectionStates, read), + try master_secret(Version, Mastersecret, SecParams, + ConnectionStates, Role) + catch + exit:_ -> + ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, key_calculation_failure) + end; - ServerName = server_name(Opts#ssl_options.server_name_indication, Host, Role), - [PeerCert | _] = ASN1Certs, - try - {TrustedCert, CertPath} = - ssl_certificate:trusted_cert_and_path(ASN1Certs, CertDbHandle, CertDbRef, - Opts#ssl_options.partial_chain), - ValidationFunAndState = validation_fun_and_state(Opts#ssl_options.verify_fun, Role, - CertDbHandle, CertDbRef, ServerName, - Opts#ssl_options.crl_check, CRLDbHandle, CertPath), - case public_key:pkix_path_validation(TrustedCert, - CertPath, - [{max_path_length, Opts#ssl_options.depth}, - {verify_fun, ValidationFunAndState}]) of - {ok, {PublicKeyInfo,_}} -> - {PeerCert, PublicKeyInfo}; - {error, Reason} -> - path_validation_alert(Reason) - end +master_secret(Version, PremasterSecret, ConnectionStates, Role) -> + #{security_parameters := SecParams} = + ssl_record:pending_connection_state(ConnectionStates, read), + + #security_parameters{prf_algorithm = PrfAlgo, + client_random = ClientRandom, + server_random = ServerRandom} = SecParams, + try master_secret(Version, + calc_master_secret(Version,PrfAlgo,PremasterSecret, + ClientRandom, ServerRandom), + SecParams, ConnectionStates, Role) catch - error:{badmatch,{asn1, Asn1Reason}} -> - %% ASN-1 decode of certificate somehow failed - ?ALERT_REC(?FATAL, ?CERTIFICATE_UNKNOWN, {failed_to_decode_certificate, Asn1Reason}); - error:OtherReason -> - ?ALERT_REC(?FATAL, ?INTERNAL_ERROR, {unexpected_error, OtherReason}) + exit:_ -> + ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, master_secret_calculation_failure) end. %%-------------------------------------------------------------------- +-spec server_key_exchange_hash(md5sha | md5 | sha | sha224 |sha256 | sha384 | sha512, binary()) -> binary(). +%% +%% Description: Calculate server key exchange hash +%%-------------------------------------------------------------------- +server_key_exchange_hash(md5sha, Value) -> + MD5 = crypto:hash(md5, Value), + SHA = crypto:hash(sha, Value), + <<MD5/binary, SHA/binary>>; + +server_key_exchange_hash(Hash, Value) -> + crypto:hash(Hash, Value). + +%%-------------------------------------------------------------------- -spec verify_connection(ssl_record:ssl_version(), #finished{}, client | server, integer(), binary(), ssl_handshake_history()) -> verified | #alert{}. %% @@ -487,292 +493,31 @@ update_handshake_history(Handshake, % special-case SSL2 client hello update_handshake_history({Handshake0, _Prev}, Data, _) -> {[Data|Handshake0], Handshake0}. -%% %%-------------------------------------------------------------------- -%% -spec decrypt_premaster_secret(binary(), #'RSAPrivateKey'{}) -> binary(). - -%% %% -%% %% Description: Public key decryption using the private key. -%% %%-------------------------------------------------------------------- -%% decrypt_premaster_secret(Secret, RSAPrivateKey) -> -%% try public_key:decrypt_private(Secret, RSAPrivateKey, -%% [{rsa_pad, rsa_pkcs1_padding}]) -%% catch -%% _:_ -> -%% throw(?ALERT_REC(?FATAL, ?DECRYPT_ERROR)) -%% end. - -premaster_secret(OtherPublicDhKey, MyPrivateKey, #'DHParameter'{} = Params) -> - try - public_key:compute_key(OtherPublicDhKey, MyPrivateKey, Params) - catch - error:computation_failed -> - throw(?ALERT_REC(?FATAL, ?ILLEGAL_PARAMETER)) - end; -premaster_secret(PublicDhKey, PrivateDhKey, #server_dh_params{dh_p = Prime, dh_g = Base}) -> - try - crypto:compute_key(dh, PublicDhKey, PrivateDhKey, [Prime, Base]) - catch - error:computation_failed -> - throw(?ALERT_REC(?FATAL, ?ILLEGAL_PARAMETER)) - end; -premaster_secret(#client_srp_public{srp_a = ClientPublicKey}, ServerKey, #srp_user{prime = Prime, - verifier = Verifier}) -> - case crypto:compute_key(srp, ClientPublicKey, ServerKey, {host, [Verifier, Prime, '6a']}) of - error -> - throw(?ALERT_REC(?FATAL, ?ILLEGAL_PARAMETER)); - PremasterSecret -> - PremasterSecret - end; -premaster_secret(#server_srp_params{srp_n = Prime, srp_g = Generator, srp_s = Salt, srp_b = Public}, - ClientKeys, {Username, Password}) -> - case ssl_srp_primes:check_srp_params(Generator, Prime) of - ok -> - DerivedKey = crypto:hash(sha, [Salt, crypto:hash(sha, [Username, <<$:>>, Password])]), - case crypto:compute_key(srp, Public, ClientKeys, {user, [DerivedKey, Prime, Generator, '6a']}) of - error -> - throw(?ALERT_REC(?FATAL, ?ILLEGAL_PARAMETER)); - PremasterSecret -> - PremasterSecret - end; - _ -> - throw(?ALERT_REC(?FATAL, ?ILLEGAL_PARAMETER)) - end; -premaster_secret(#client_rsa_psk_identity{ - identity = PSKIdentity, - exchange_keys = #encrypted_premaster_secret{premaster_secret = EncPMS} - }, #'RSAPrivateKey'{} = Key, PSKLookup) -> - PremasterSecret = premaster_secret(EncPMS, Key), - psk_secret(PSKIdentity, PSKLookup, PremasterSecret); -premaster_secret(#server_dhe_psk_params{ - hint = IdentityHint, - dh_params = #server_dh_params{dh_y = PublicDhKey} = Params}, - PrivateDhKey, - LookupFun) -> - PremasterSecret = premaster_secret(PublicDhKey, PrivateDhKey, Params), - psk_secret(IdentityHint, LookupFun, PremasterSecret); - -premaster_secret(#server_ecdhe_psk_params{ - hint = IdentityHint, - dh_params = #server_ecdh_params{ - public = ECServerPubKey}}, - PrivateEcDhKey, - LookupFun) -> - PremasterSecret = premaster_secret(#'ECPoint'{point = ECServerPubKey}, PrivateEcDhKey), - psk_secret(IdentityHint, LookupFun, PremasterSecret); - -premaster_secret({rsa_psk, PSKIdentity}, PSKLookup, RSAPremasterSecret) -> - psk_secret(PSKIdentity, PSKLookup, RSAPremasterSecret); - -premaster_secret(#client_ecdhe_psk_identity{ - identity = PSKIdentity, - dh_public = PublicEcDhPoint}, PrivateEcDhKey, PSKLookup) -> - PremasterSecret = premaster_secret(#'ECPoint'{point = PublicEcDhPoint}, PrivateEcDhKey), - psk_secret(PSKIdentity, PSKLookup, PremasterSecret). - -premaster_secret(#client_dhe_psk_identity{ - identity = PSKIdentity, - dh_public = PublicDhKey}, PrivateKey, #'DHParameter'{} = Params, PSKLookup) -> - PremasterSecret = premaster_secret(PublicDhKey, PrivateKey, Params), - psk_secret(PSKIdentity, PSKLookup, PremasterSecret). - -premaster_secret(#client_psk_identity{identity = PSKIdentity}, PSKLookup) -> - psk_secret(PSKIdentity, PSKLookup); -premaster_secret({psk, PSKIdentity}, PSKLookup) -> - psk_secret(PSKIdentity, PSKLookup); -premaster_secret(#'ECPoint'{} = ECPoint, #'ECPrivateKey'{} = ECDHKeys) -> - public_key:compute_key(ECPoint, ECDHKeys); -premaster_secret(EncSecret, #'RSAPrivateKey'{} = RSAPrivateKey) -> - try public_key:decrypt_private(EncSecret, RSAPrivateKey, - [{rsa_pad, rsa_pkcs1_padding}]) - catch - _:_ -> - throw(?ALERT_REC(?FATAL, ?DECRYPT_ERROR)) - end. -%%-------------------------------------------------------------------- --spec server_key_exchange_hash(md5sha | md5 | sha | sha224 |sha256 | sha384 | sha512, binary()) -> binary(). -%% -%% Description: Calculate server key exchange hash -%%-------------------------------------------------------------------- -server_key_exchange_hash(md5sha, Value) -> - MD5 = crypto:hash(md5, Value), - SHA = crypto:hash(sha, Value), - <<MD5/binary, SHA/binary>>; - -server_key_exchange_hash(Hash, Value) -> - crypto:hash(Hash, Value). -%%-------------------------------------------------------------------- --spec prf(ssl_record:ssl_version(), non_neg_integer(), binary(), binary(), [binary()], non_neg_integer()) -> - {ok, binary()} | {error, undefined}. -%% -%% Description: use the TLS PRF to generate key material -%%-------------------------------------------------------------------- -prf({3,0}, _, _, _, _, _) -> - {error, undefined}; -prf({3,_N}, PRFAlgo, Secret, Label, Seed, WantedLength) -> - {ok, tls_v1:prf(PRFAlgo, Secret, Label, Seed, WantedLength)}. - - -%%-------------------------------------------------------------------- --spec select_hashsign(#hash_sign_algos{} | undefined, undefined | binary(), - atom(), [atom()], ssl_record:ssl_version()) -> - {atom(), atom()} | undefined | #alert{}. - -%% -%% Description: Handles signature_algorithms hello extension (server) -%%-------------------------------------------------------------------- -select_hashsign(_, undefined, _, _, _Version) -> - {null, anon}; -%% The signature_algorithms extension was introduced with TLS 1.2. Ignore it if we have -%% negotiated a lower version. -select_hashsign(HashSigns, Cert, KeyExAlgo, - undefined, {Major, Minor} = Version) when Major >= 3 andalso Minor >= 3-> - select_hashsign(HashSigns, Cert, KeyExAlgo, tls_v1:default_signature_algs(Version), Version); -select_hashsign(#hash_sign_algos{hash_sign_algos = HashSigns}, Cert, KeyExAlgo, SupportedHashSigns, - {Major, Minor}) when Major >= 3 andalso Minor >= 3 -> - #'OTPCertificate'{tbsCertificate = TBSCert} = public_key:pkix_decode_cert(Cert, otp), - #'OTPCertificate'{tbsCertificate = TBSCert, - signatureAlgorithm = {_,SignAlgo, _}} = public_key:pkix_decode_cert(Cert, otp), - #'OTPSubjectPublicKeyInfo'{algorithm = {_, SubjAlgo, _}} = - TBSCert#'OTPTBSCertificate'.subjectPublicKeyInfo, - - Sign = sign_algo(SignAlgo), - SubSing = sign_algo(SubjAlgo), - - case lists:filter(fun({_, S} = Algos) when S == Sign -> - is_acceptable_hash_sign(Algos, Sign, - SubSing, KeyExAlgo, SupportedHashSigns); - (_) -> - false - end, HashSigns) of - [] -> - ?ALERT_REC(?FATAL, ?INSUFFICIENT_SECURITY, no_suitable_signature_algorithm); - [HashSign | _] -> - HashSign - end; -select_hashsign(_, Cert, _, _, Version) -> - #'OTPCertificate'{tbsCertificate = TBSCert} = public_key:pkix_decode_cert(Cert, otp), - #'OTPSubjectPublicKeyInfo'{algorithm = {_,Algo, _}} = TBSCert#'OTPTBSCertificate'.subjectPublicKeyInfo, - select_hashsign_algs(undefined, Algo, Version). -%%-------------------------------------------------------------------- --spec select_hashsign(#certificate_request{}, binary(), - [atom()], ssl_record:ssl_version()) -> - {atom(), atom()} | #alert{}. - -%% -%% Description: Handles signature algorithms selection for certificate requests (client) -%%-------------------------------------------------------------------- -select_hashsign(#certificate_request{}, undefined, _, {Major, Minor}) when Major >= 3 andalso Minor >= 3-> - %% There client does not have a certificate and will send an empty reply, the server may fail - %% or accept the connection by its own preference. No signature algorihms needed as there is - %% no certificate to verify. - {undefined, undefined}; - -select_hashsign(#certificate_request{hashsign_algorithms = #hash_sign_algos{hash_sign_algos = HashSigns}, - certificate_types = Types}, Cert, SupportedHashSigns, - {Major, Minor}) when Major >= 3 andalso Minor >= 3-> - #'OTPCertificate'{tbsCertificate = TBSCert} = public_key:pkix_decode_cert(Cert, otp), - #'OTPCertificate'{tbsCertificate = TBSCert, - signatureAlgorithm = {_,SignAlgo, _}} = public_key:pkix_decode_cert(Cert, otp), - #'OTPSubjectPublicKeyInfo'{algorithm = {_, SubjAlgo, _}} = - TBSCert#'OTPTBSCertificate'.subjectPublicKeyInfo, - - Sign = sign_algo(SignAlgo), - SubSign = sign_algo(SubjAlgo), - - case is_acceptable_cert_type(SubSign, HashSigns, Types) andalso is_supported_sign(Sign, HashSigns) of - true -> - case lists:filter(fun({_, S} = Algos) when S == SubSign -> - is_acceptable_hash_sign(Algos, SupportedHashSigns); - (_) -> - false - end, HashSigns) of - [] -> - ?ALERT_REC(?FATAL, ?INSUFFICIENT_SECURITY, no_suitable_signature_algorithm); - [HashSign | _] -> - HashSign - end; - false -> - ?ALERT_REC(?FATAL, ?INSUFFICIENT_SECURITY, no_suitable_signature_algorithm) - end; -select_hashsign(#certificate_request{}, Cert, _, Version) -> - select_hashsign(undefined, Cert, undefined, [], Version). - -%%-------------------------------------------------------------------- --spec select_hashsign_algs({atom(), atom()}| undefined, oid(), ssl_record:ssl_version()) -> - {atom(), atom()}. - -%% Description: For TLS 1.2 hash function and signature algorithm pairs can be -%% negotiated with the signature_algorithms extension, -%% for previous versions always use appropriate defaults. -%% RFC 5246, Sect. 7.4.1.4.1. Signature Algorithms -%% If the client does not send the signature_algorithms extension, the -%% server MUST do the following: (e.i defaults for TLS 1.2) -%% -%% - If the negotiated key exchange algorithm is one of (RSA, DHE_RSA, -%% DH_RSA, RSA_PSK, ECDH_RSA, ECDHE_RSA), behave as if client had -%% sent the value {sha1,rsa}. -%% -%% - If the negotiated key exchange algorithm is one of (DHE_DSS, -%% DH_DSS), behave as if the client had sent the value {sha1,dsa}. -%% -%% - If the negotiated key exchange algorithm is one of (ECDH_ECDSA, -%% ECDHE_ECDSA), behave as if the client had sent value {sha1,ecdsa}. - -%%-------------------------------------------------------------------- -select_hashsign_algs(HashSign, _, {Major, Minor}) when HashSign =/= undefined andalso - Major >= 3 andalso Minor >= 3 -> - HashSign; -select_hashsign_algs(undefined, ?rsaEncryption, {Major, Minor}) when Major >= 3 andalso Minor >= 3 -> - {sha, rsa}; -select_hashsign_algs(undefined,?'id-ecPublicKey', _) -> - {sha, ecdsa}; -select_hashsign_algs(undefined, ?rsaEncryption, _) -> - {md5sha, rsa}; -select_hashsign_algs(undefined, ?'id-dsa', _) -> - {sha, dsa}. - - -%%-------------------------------------------------------------------- --spec master_secret(ssl_record:ssl_version(), #session{} | binary(), ssl_record:connection_states(), - client | server) -> {binary(), ssl_record:connection_states()} | #alert{}. -%% -%% Description: Sets or calculates the master secret and calculate keys, -%% updating the pending connection states. The Mastersecret and the update -%% connection states are returned or an alert if the calculation fails. -%%------------------------------------------------------------------- -master_secret(Version, #session{master_secret = Mastersecret}, - ConnectionStates, Role) -> - #{security_parameters := SecParams} = - ssl_record:pending_connection_state(ConnectionStates, read), - try master_secret(Version, Mastersecret, SecParams, - ConnectionStates, Role) - catch - exit:_ -> - ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, key_calculation_failure) - end; - -master_secret(Version, PremasterSecret, ConnectionStates, Role) -> +verify_server_key(#server_key_params{params_bin = EncParams, + signature = Signature}, + HashSign = {HashAlgo, _}, + ConnectionStates, Version, PubKeyInfo) -> #{security_parameters := SecParams} = ssl_record:pending_connection_state(ConnectionStates, read), - - #security_parameters{prf_algorithm = PrfAlgo, - client_random = ClientRandom, + #security_parameters{client_random = ClientRandom, server_random = ServerRandom} = SecParams, - try master_secret(Version, - calc_master_secret(Version,PrfAlgo,PremasterSecret, - ClientRandom, ServerRandom), - SecParams, ConnectionStates, Role) - catch - exit:_ -> - ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, master_secret_calculation_failure) - end. + Hash = server_key_exchange_hash(HashAlgo, + <<ClientRandom/binary, + ServerRandom/binary, + EncParams/binary>>), + verify_signature(Version, Hash, HashSign, Signature, PubKeyInfo). + +select_version(RecordCB, ClientVersion, Versions) -> + do_select_version(RecordCB, ClientVersion, Versions). + +%%==================================================================== +%% Encode handshake +%%==================================================================== -%%-------------Encode/Decode -------------------------------- encode_handshake(#next_protocol{selected_protocol = SelectedProtocol}, _Version) -> PaddingLength = 32 - ((byte_size(SelectedProtocol) + 2) rem 32), {?NEXT_PROTOCOL, <<?BYTE((byte_size(SelectedProtocol))), SelectedProtocol/binary, ?BYTE(PaddingLength), 0:(PaddingLength * 8)>>}; - encode_handshake(#server_hello{server_version = {Major, Minor}, random = Random, session_id = Session_ID, @@ -894,71 +639,6 @@ encode_hello_extensions([#sni{hostname = Hostname} | Rest], Acc) -> ?UINT16(HostLen), HostnameBin/binary, Acc/binary>>). -enc_server_key_exchange(Version, Params, {HashAlgo, SignAlgo}, - ClientRandom, ServerRandom, PrivateKey) -> - EncParams = encode_server_key(Params), - case HashAlgo of - null -> - #server_key_params{params = Params, - params_bin = EncParams, - hashsign = {null, anon}, - signature = <<>>}; - _ -> - Hash = - server_key_exchange_hash(HashAlgo, <<ClientRandom/binary, - ServerRandom/binary, - EncParams/binary>>), - Signature = digitally_signed(Version, Hash, HashAlgo, PrivateKey), - #server_key_params{params = Params, - params_bin = EncParams, - hashsign = {HashAlgo, SignAlgo}, - signature = Signature} - end. - -%%-------------------------------------------------------------------- --spec decode_client_key(binary(), ssl_cipher:key_algo(), ssl_record:ssl_version()) -> - #encrypted_premaster_secret{} - | #client_diffie_hellman_public{} - | #client_ec_diffie_hellman_public{} - | #client_psk_identity{} - | #client_dhe_psk_identity{} - | #client_ecdhe_psk_identity{} - | #client_rsa_psk_identity{} - | #client_srp_public{}. -%% -%% Description: Decode client_key data and return appropriate type -%%-------------------------------------------------------------------- -decode_client_key(ClientKey, Type, Version) -> - dec_client_key(ClientKey, key_exchange_alg(Type), Version). - -%%-------------------------------------------------------------------- --spec decode_server_key(binary(), ssl_cipher:key_algo(), ssl_record:ssl_version()) -> - #server_key_params{}. -%% -%% Description: Decode server_key data and return appropriate type -%%-------------------------------------------------------------------- -decode_server_key(ServerKey, Type, Version) -> - dec_server_key(ServerKey, key_exchange_alg(Type), Version). - -%% -%% Description: Encode and decode functions for ALPN extension data. -%%-------------------------------------------------------------------- - -%% While the RFC opens the door to allow ALPN during renegotiation, in practice -%% this does not work and it is recommended to ignore any ALPN extension during -%% renegotiation, as done here. -encode_alpn(_, true) -> - undefined; -encode_alpn(undefined, _) -> - undefined; -encode_alpn(Protocols, _) -> - #alpn{extension_data = lists:foldl(fun encode_protocol/2, <<>>, Protocols)}. - -decode_alpn(undefined) -> - undefined; -decode_alpn(#alpn{extension_data=Data}) -> - decode_protocols(Data, []). - encode_client_protocol_negotiation(undefined, _) -> undefined; encode_client_protocol_negotiation(_, false) -> @@ -972,6 +652,10 @@ encode_protocols_advertised_on_server(undefined) -> encode_protocols_advertised_on_server(Protocols) -> #next_protocol_negotiation{extension_data = lists:foldl(fun encode_protocol/2, <<>>, Protocols)}. +%%==================================================================== +%% Decode handshake +%%==================================================================== + decode_handshake(_, ?HELLO_REQUEST, <<>>) -> #hello_request{}; decode_handshake(_, ?NEXT_PROTOCOL, <<?BYTE(SelectedProtocolLength), @@ -1004,7 +688,6 @@ decode_handshake(_Version, ?SERVER_HELLO, <<?BYTE(Major), ?BYTE(Minor), Random:3 cipher_suite = Cipher_suite, compression_method = Comp_method, extensions = HelloExtensions}; - decode_handshake(_Version, ?CERTIFICATE, <<?UINT24(ACLen), ASN1Certs:ACLen/binary>>) -> #certificate{asn1_certificates = certs_to_list(ASN1Certs)}; decode_handshake(_Version, ?SERVER_KEY_EXCHANGE, Keys) -> @@ -1051,83 +734,30 @@ decode_hello_extensions({client, <<?UINT16(ExtLen), Extensions:ExtLen/binary>>}) decode_hello_extensions(Extensions) -> dec_hello_extensions(Extensions, #hello_extensions{}). -dec_server_key(<<?UINT16(PLen), P:PLen/binary, - ?UINT16(GLen), G:GLen/binary, - ?UINT16(YLen), Y:YLen/binary, _/binary>> = KeyStruct, - ?KEY_EXCHANGE_DIFFIE_HELLMAN, Version) -> - Params = #server_dh_params{dh_p = P, dh_g = G, dh_y = Y}, - {BinMsg, HashSign, Signature} = dec_server_key_params(PLen + GLen + YLen + 6, KeyStruct, Version), - #server_key_params{params = Params, - params_bin = BinMsg, - hashsign = HashSign, - signature = Signature}; -%% ECParameters with named_curve -%% TODO: explicit curve -dec_server_key(<<?BYTE(?NAMED_CURVE), ?UINT16(CurveID), - ?BYTE(PointLen), ECPoint:PointLen/binary, - _/binary>> = KeyStruct, - ?KEY_EXCHANGE_EC_DIFFIE_HELLMAN, Version) -> - Params = #server_ecdh_params{curve = {namedCurve, tls_v1:enum_to_oid(CurveID)}, - public = ECPoint}, - {BinMsg, HashSign, Signature} = dec_server_key_params(PointLen + 4, KeyStruct, Version), - #server_key_params{params = Params, - params_bin = BinMsg, - hashsign = HashSign, - signature = Signature}; -dec_server_key(<<?UINT16(Len), PskIdentityHint:Len/binary, _/binary>> = KeyStruct, - KeyExchange, Version) - when KeyExchange == ?KEY_EXCHANGE_PSK; KeyExchange == ?KEY_EXCHANGE_RSA_PSK -> - Params = #server_psk_params{ - hint = PskIdentityHint}, - {BinMsg, HashSign, Signature} = dec_server_key_params(Len + 2, KeyStruct, Version), - #server_key_params{params = Params, - params_bin = BinMsg, - hashsign = HashSign, - signature = Signature}; +%%-------------------------------------------------------------------- +-spec decode_server_key(binary(), ssl_cipher:key_algo(), ssl_record:ssl_version()) -> + #server_key_params{}. +%% +%% Description: Decode server_key data and return appropriate type +%%-------------------------------------------------------------------- +decode_server_key(ServerKey, Type, Version) -> + dec_server_key(ServerKey, key_exchange_alg(Type), Version). -dec_server_key(<<?UINT16(Len), IdentityHint:Len/binary, - ?UINT16(PLen), P:PLen/binary, - ?UINT16(GLen), G:GLen/binary, - ?UINT16(YLen), Y:YLen/binary, _/binary>> = KeyStruct, - ?KEY_EXCHANGE_DHE_PSK, Version) -> - DHParams = #server_dh_params{dh_p = P, dh_g = G, dh_y = Y}, - Params = #server_dhe_psk_params{ - hint = IdentityHint, - dh_params = DHParams}, - {BinMsg, HashSign, Signature} = dec_server_key_params(Len + PLen + GLen + YLen + 8, KeyStruct, Version), - #server_key_params{params = Params, - params_bin = BinMsg, - hashsign = HashSign, - signature = Signature}; -dec_server_key(<<?UINT16(Len), IdentityHint:Len/binary, - ?BYTE(?NAMED_CURVE), ?UINT16(CurveID), - ?BYTE(PointLen), ECPoint:PointLen/binary, - _/binary>> = KeyStruct, - ?KEY_EXCHANGE_EC_DIFFIE_HELLMAN_PSK, Version) -> - DHParams = #server_ecdh_params{ - curve = {namedCurve, tls_v1:enum_to_oid(CurveID)}, - public = ECPoint}, - Params = #server_ecdhe_psk_params{ - hint = IdentityHint, - dh_params = DHParams}, - {BinMsg, HashSign, Signature} = dec_server_key_params(Len + 2 + PointLen + 4, KeyStruct, Version), - #server_key_params{params = Params, - params_bin = BinMsg, - hashsign = HashSign, - signature = Signature}; -dec_server_key(<<?UINT16(NLen), N:NLen/binary, - ?UINT16(GLen), G:GLen/binary, - ?BYTE(SLen), S:SLen/binary, - ?UINT16(BLen), B:BLen/binary, _/binary>> = KeyStruct, - ?KEY_EXCHANGE_SRP, Version) -> - Params = #server_srp_params{srp_n = N, srp_g = G, srp_s = S, srp_b = B}, - {BinMsg, HashSign, Signature} = dec_server_key_params(NLen + GLen + SLen + BLen + 7, KeyStruct, Version), - #server_key_params{params = Params, - params_bin = BinMsg, - hashsign = HashSign, - signature = Signature}; -dec_server_key(_, KeyExchange, _) -> - throw(?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, {unknown_or_malformed_key_exchange, KeyExchange})). +%%-------------------------------------------------------------------- +-spec decode_client_key(binary(), ssl_cipher:key_algo(), ssl_record:ssl_version()) -> + #encrypted_premaster_secret{} + | #client_diffie_hellman_public{} + | #client_ec_diffie_hellman_public{} + | #client_psk_identity{} + | #client_dhe_psk_identity{} + | #client_ecdhe_psk_identity{} + | #client_rsa_psk_identity{} + | #client_srp_public{}. +%% +%% Description: Decode client_key data and return appropriate type +%%-------------------------------------------------------------------- +decode_client_key(ClientKey, Type, Version) -> + dec_client_key(ClientKey, key_exchange_alg(Type), Version). %%-------------------------------------------------------------------- -spec decode_suites('2_bytes'|'3_bytes', binary()) -> list(). @@ -1139,7 +769,9 @@ decode_suites('2_bytes', Dec) -> decode_suites('3_bytes', Dec) -> from_3bytes(Dec). -%%-------------Cipeher suite handling -------------------------------- +%%==================================================================== +%% Cipher suite handling +%%==================================================================== available_suites(UserSuites, Version) -> lists:filtermap(fun(Suite) -> @@ -1152,61 +784,42 @@ available_suites(ServerCert, UserSuites, Version, undefined, Curve) -> available_suites(ServerCert, UserSuites, Version, HashSigns, Curve) -> Suites = available_suites(ServerCert, UserSuites, Version, undefined, Curve), filter_hashsigns(Suites, [ssl_cipher:suite_definition(Suite) || Suite <- Suites], HashSigns, []). -filter_hashsigns([], [], _, Acc) -> - lists:reverse(Acc); -filter_hashsigns([Suite | Suites], [{KeyExchange,_,_,_} | Algos], HashSigns, - Acc) when KeyExchange == dhe_ecdsa; - KeyExchange == ecdhe_ecdsa -> - do_filter_hashsigns(ecdsa, Suite, Suites, Algos, HashSigns, Acc); - -filter_hashsigns([Suite | Suites], [{KeyExchange,_,_,_} | Algos], HashSigns, - Acc) when KeyExchange == rsa; - KeyExchange == dhe_rsa; - KeyExchange == ecdhe_rsa; - KeyExchange == srp_rsa; - KeyExchange == rsa_psk -> - do_filter_hashsigns(rsa, Suite, Suites, Algos, HashSigns, Acc); -filter_hashsigns([Suite | Suites], [{KeyExchange,_,_,_} | Algos], HashSigns, Acc) when - KeyExchange == dhe_dss; - KeyExchange == srp_dss -> - do_filter_hashsigns(dsa, Suite, Suites, Algos, HashSigns, Acc); -filter_hashsigns([Suite | Suites], [{KeyExchange,_,_,_} | Algos], HashSigns, Acc) when - KeyExchange == dh_dss; - KeyExchange == dh_rsa; - KeyExchange == dh_ecdsa; - KeyExchange == ecdh_rsa; - KeyExchange == ecdh_ecdsa -> - %% Fixed DH certificates MAY be signed with any hash/signature - %% algorithm pair appearing in the hash_sign extension. The names - %% DH_DSS, DH_RSA, ECDH_ECDSA, and ECDH_RSA are historical. - filter_hashsigns(Suites, Algos, HashSigns, [Suite| Acc]); -filter_hashsigns([Suite | Suites], [{KeyExchange,_,_,_} | Algos], HashSigns, Acc) when - KeyExchange == dh_anon; - KeyExchange == ecdh_anon; - KeyExchange == srp_anon; - KeyExchange == psk; - KeyExchange == dhe_psk; - KeyExchange == ecdhe_psk -> - %% In this case hashsigns is not used as the kexchange is anonaymous - filter_hashsigns(Suites, Algos, HashSigns, [Suite| Acc]). - -do_filter_hashsigns(SignAlgo, Suite, Suites, Algos, HashSigns, Acc) -> - case lists:keymember(SignAlgo, 2, HashSigns) of - true -> - filter_hashsigns(Suites, Algos, HashSigns, [Suite| Acc]); - false -> - filter_hashsigns(Suites, Algos, HashSigns, Acc) - end. -unavailable_ecc_suites(no_curve) -> - ssl_cipher:ec_keyed_suites(); -unavailable_ecc_suites(_) -> - []. +available_signature_algs(undefined, _) -> + undefined; +available_signature_algs(SupportedHashSigns, Version) when Version >= {3, 3} -> + #hash_sign_algos{hash_sign_algos = SupportedHashSigns}; +available_signature_algs(_, _) -> + undefined. +available_signature_algs(undefined, SupportedHashSigns, _, Version) when + Version >= {3,3} -> + SupportedHashSigns; +available_signature_algs(#hash_sign_algos{hash_sign_algos = ClientHashSigns}, SupportedHashSigns, + _, Version) when Version >= {3,3} -> + sets:to_list(sets:intersection(sets:from_list(ClientHashSigns), + sets:from_list(SupportedHashSigns))); +available_signature_algs(_, _, _, _) -> + undefined. +cipher_suites(Suites, Renegotiation, true) -> + %% TLS_FALLBACK_SCSV should be placed last -RFC7507 + cipher_suites(Suites, Renegotiation) ++ [?TLS_FALLBACK_SCSV]; +cipher_suites(Suites, Renegotiation, false) -> + cipher_suites(Suites, Renegotiation). cipher_suites(Suites, false) -> [?TLS_EMPTY_RENEGOTIATION_INFO_SCSV | Suites]; cipher_suites(Suites, true) -> Suites. +%%-------------------------------------------------------------------- +-spec prf(ssl_record:ssl_version(), non_neg_integer(), binary(), binary(), [binary()], non_neg_integer()) -> + {ok, binary()} | {error, undefined}. +%% +%% Description: use the TLS PRF to generate key material +%%-------------------------------------------------------------------- +prf({3,0}, _, _, _, _, _) -> + {error, undefined}; +prf({3,_N}, PRFAlgo, Secret, Label, Seed, WantedLength) -> + {ok, tls_v1:prf(PRFAlgo, Secret, Label, Seed, WantedLength)}. select_session(SuggestedSessionId, CipherSuites, HashSigns, Compressions, Port, #session{ecc = ECCCurve} = Session, Version, @@ -1227,68 +840,121 @@ select_session(SuggestedSessionId, CipherSuites, HashSigns, Compressions, Port, {resumed, Resumed} end. -%% Deprecated? supported_ecc({Major, Minor}) when ((Major == 3) and (Minor >= 1)) orelse (Major > 3) -> Curves = tls_v1:ecc_curves(Minor), #elliptic_curves{elliptic_curve_list = Curves}; supported_ecc(_) -> #elliptic_curves{elliptic_curve_list = []}. -%%-------------certificate handling -------------------------------- - -certificate_types(_, {N, M}) when N >= 3 andalso M >= 3 -> - case proplists:get_bool(ecdsa, - proplists:get_value(public_keys, crypto:supports())) of - true -> - <<?BYTE(?ECDSA_SIGN), ?BYTE(?RSA_SIGN), ?BYTE(?DSS_SIGN)>>; - false -> - <<?BYTE(?RSA_SIGN), ?BYTE(?DSS_SIGN)>> +premaster_secret(OtherPublicDhKey, MyPrivateKey, #'DHParameter'{} = Params) -> + try + public_key:compute_key(OtherPublicDhKey, MyPrivateKey, Params) + catch + error:computation_failed -> + throw(?ALERT_REC(?FATAL, ?ILLEGAL_PARAMETER)) + end; +premaster_secret(PublicDhKey, PrivateDhKey, #server_dh_params{dh_p = Prime, dh_g = Base}) -> + try + crypto:compute_key(dh, PublicDhKey, PrivateDhKey, [Prime, Base]) + catch + error:computation_failed -> + throw(?ALERT_REC(?FATAL, ?ILLEGAL_PARAMETER)) end; +premaster_secret(#client_srp_public{srp_a = ClientPublicKey}, ServerKey, #srp_user{prime = Prime, + verifier = Verifier}) -> + case crypto:compute_key(srp, ClientPublicKey, ServerKey, {host, [Verifier, Prime, '6a']}) of + error -> + throw(?ALERT_REC(?FATAL, ?ILLEGAL_PARAMETER)); + PremasterSecret -> + PremasterSecret + end; +premaster_secret(#server_srp_params{srp_n = Prime, srp_g = Generator, srp_s = Salt, srp_b = Public}, + ClientKeys, {Username, Password}) -> + case ssl_srp_primes:check_srp_params(Generator, Prime) of + ok -> + DerivedKey = crypto:hash(sha, [Salt, crypto:hash(sha, [Username, <<$:>>, Password])]), + case crypto:compute_key(srp, Public, ClientKeys, {user, [DerivedKey, Prime, Generator, '6a']}) of + error -> + throw(?ALERT_REC(?FATAL, ?ILLEGAL_PARAMETER)); + PremasterSecret -> + PremasterSecret + end; + _ -> + throw(?ALERT_REC(?FATAL, ?ILLEGAL_PARAMETER)) + end; +premaster_secret(#client_rsa_psk_identity{ + identity = PSKIdentity, + exchange_keys = #encrypted_premaster_secret{premaster_secret = EncPMS} + }, #'RSAPrivateKey'{} = Key, PSKLookup) -> + PremasterSecret = premaster_secret(EncPMS, Key), + psk_secret(PSKIdentity, PSKLookup, PremasterSecret); +premaster_secret(#server_dhe_psk_params{ + hint = IdentityHint, + dh_params = #server_dh_params{dh_y = PublicDhKey} = Params}, + PrivateDhKey, + LookupFun) -> + PremasterSecret = premaster_secret(PublicDhKey, PrivateDhKey, Params), + psk_secret(IdentityHint, LookupFun, PremasterSecret); +premaster_secret(#server_ecdhe_psk_params{ + hint = IdentityHint, + dh_params = #server_ecdh_params{ + public = ECServerPubKey}}, + PrivateEcDhKey, + LookupFun) -> + PremasterSecret = premaster_secret(#'ECPoint'{point = ECServerPubKey}, PrivateEcDhKey), + psk_secret(IdentityHint, LookupFun, PremasterSecret); +premaster_secret({rsa_psk, PSKIdentity}, PSKLookup, RSAPremasterSecret) -> + psk_secret(PSKIdentity, PSKLookup, RSAPremasterSecret); +premaster_secret(#client_ecdhe_psk_identity{ + identity = PSKIdentity, + dh_public = PublicEcDhPoint}, PrivateEcDhKey, PSKLookup) -> + PremasterSecret = premaster_secret(#'ECPoint'{point = PublicEcDhPoint}, PrivateEcDhKey), + psk_secret(PSKIdentity, PSKLookup, PremasterSecret). +premaster_secret(#client_dhe_psk_identity{ + identity = PSKIdentity, + dh_public = PublicDhKey}, PrivateKey, #'DHParameter'{} = Params, PSKLookup) -> + PremasterSecret = premaster_secret(PublicDhKey, PrivateKey, Params), + psk_secret(PSKIdentity, PSKLookup, PremasterSecret). +premaster_secret(#client_psk_identity{identity = PSKIdentity}, PSKLookup) -> + psk_secret(PSKIdentity, PSKLookup); +premaster_secret({psk, PSKIdentity}, PSKLookup) -> + psk_secret(PSKIdentity, PSKLookup); +premaster_secret(#'ECPoint'{} = ECPoint, #'ECPrivateKey'{} = ECDHKeys) -> + public_key:compute_key(ECPoint, ECDHKeys); +premaster_secret(EncSecret, #'RSAPrivateKey'{} = RSAPrivateKey) -> + try public_key:decrypt_private(EncSecret, RSAPrivateKey, + [{rsa_pad, rsa_pkcs1_padding}]) + catch + _:_ -> + throw(?ALERT_REC(?FATAL, ?DECRYPT_ERROR)) + end. +%%==================================================================== +%% Extensions handling +%%==================================================================== +client_hello_extensions(Version, CipherSuites, + #ssl_options{signature_algs = SupportedHashSigns, + eccs = SupportedECCs} = SslOpts, ConnectionStates, Renegotiation) -> + {EcPointFormats, EllipticCurves} = + case advertises_ec_ciphers(lists:map(fun ssl_cipher:suite_definition/1, CipherSuites)) of + true -> + client_ecc_extensions(SupportedECCs); + false -> + {undefined, undefined} + end, + SRP = srp_user(SslOpts), -certificate_types({KeyExchange, _, _, _}, _) when KeyExchange == rsa; - KeyExchange == dh_rsa; - KeyExchange == dhe_rsa; - KeyExchange == ecdhe_rsa -> - <<?BYTE(?RSA_SIGN)>>; - -certificate_types({KeyExchange, _, _, _}, _) when KeyExchange == dh_dss; - KeyExchange == dhe_dss; - KeyExchange == srp_dss -> - <<?BYTE(?DSS_SIGN)>>; - -certificate_types({KeyExchange, _, _, _}, _) when KeyExchange == dh_ecdsa; - KeyExchange == dhe_ecdsa; - KeyExchange == ecdh_ecdsa; - KeyExchange == ecdhe_ecdsa -> - <<?BYTE(?ECDSA_SIGN)>>; - -certificate_types(_, _) -> - <<?BYTE(?RSA_SIGN)>>. - -certificate_authorities(CertDbHandle, CertDbRef) -> - Authorities = certificate_authorities_from_db(CertDbHandle, CertDbRef), - Enc = fun(#'OTPCertificate'{tbsCertificate=TBSCert}) -> - OTPSubj = TBSCert#'OTPTBSCertificate'.subject, - DNEncodedBin = public_key:pkix_encode('Name', OTPSubj, otp), - DNEncodedLen = byte_size(DNEncodedBin), - <<?UINT16(DNEncodedLen), DNEncodedBin/binary>> - end, - list_to_binary([Enc(Cert) || {_, Cert} <- Authorities]). - -certificate_authorities_from_db(CertDbHandle, CertDbRef) when is_reference(CertDbRef) -> - ConnectionCerts = fun({{Ref, _, _}, Cert}, Acc) when Ref == CertDbRef -> - [Cert | Acc]; - (_, Acc) -> - Acc - end, - ssl_pkix_db:foldl(ConnectionCerts, [], CertDbHandle); -certificate_authorities_from_db(_CertDbHandle, {extracted, CertDbData}) -> - %% Cache disabled, Ref contains data - lists:foldl(fun({decoded, {_Key,Cert}}, Acc) -> [Cert | Acc] end, - [], CertDbData). - - -%%-------------Extension handling -------------------------------- + #hello_extensions{ + renegotiation_info = renegotiation_info(tls_record, client, + ConnectionStates, Renegotiation), + srp = SRP, + signature_algs = available_signature_algs(SupportedHashSigns, Version), + ec_point_formats = EcPointFormats, + elliptic_curves = EllipticCurves, + alpn = encode_alpn(SslOpts#ssl_options.alpn_advertised_protocols, Renegotiation), + next_protocol_negotiation = + encode_client_protocol_negotiation(SslOpts#ssl_options.next_protocol_selector, + Renegotiation), + sni = sni(SslOpts#ssl_options.server_name_indication)}. handle_client_hello_extensions(RecordCB, Random, ClientCipherSuites, #hello_extensions{renegotiation_info = Info, @@ -1365,233 +1031,206 @@ handle_server_hello_extensions(RecordCB, Random, CipherSuite, Compression, ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, too_many_protocols_in_server_hello) end. -select_version(RecordCB, ClientVersion, Versions) -> - do_select_version(RecordCB, ClientVersion, Versions). - -do_select_version(_, ClientVersion, []) -> - ClientVersion; -do_select_version(RecordCB, ClientVersion, [Version | Versions]) -> - case RecordCB:is_higher(Version, ClientVersion) of - true -> - %% Version too high for client - keep looking - do_select_version(RecordCB, ClientVersion, Versions); - false -> - %% Version ok for client - look for a higher - do_select_version(RecordCB, ClientVersion, Versions, Version) - end. -%% -do_select_version(_, _, [], GoodVersion) -> - GoodVersion; -do_select_version( - RecordCB, ClientVersion, [Version | Versions], GoodVersion) -> - BetterVersion = - case RecordCB:is_higher(Version, ClientVersion) of - true -> - %% Version too high for client - GoodVersion; - false -> - %% Version ok for client - case RecordCB:is_higher(Version, GoodVersion) of - true -> - %% Use higher version - Version; - false -> - GoodVersion - end - end, - do_select_version(RecordCB, ClientVersion, Versions, BetterVersion). +select_curve(Client, Server) -> + select_curve(Client, Server, false). -renegotiation_info(_, client, _, false) -> - #renegotiation_info{renegotiated_connection = undefined}; -renegotiation_info(_RecordCB, server, ConnectionStates, false) -> - ConnectionState = ssl_record:current_connection_state(ConnectionStates, read), - case maps:get(secure_renegotiation, ConnectionState) of - true -> - #renegotiation_info{renegotiated_connection = ?byte(0)}; - false -> - #renegotiation_info{renegotiated_connection = undefined} - end; -renegotiation_info(_RecordCB, client, ConnectionStates, true) -> - ConnectionState = ssl_record:current_connection_state(ConnectionStates, read), - case maps:get(secure_renegotiation, ConnectionState) of - true -> - Data = maps:get(client_verify_data, ConnectionState), - #renegotiation_info{renegotiated_connection = Data}; - false -> - #renegotiation_info{renegotiated_connection = undefined} +select_curve(#elliptic_curves{elliptic_curve_list = ClientCurves}, + #elliptic_curves{elliptic_curve_list = ServerCurves}, + ServerOrder) -> + case ServerOrder of + false -> + select_shared_curve(ClientCurves, ServerCurves); + true -> + select_shared_curve(ServerCurves, ClientCurves) end; +select_curve(undefined, _, _) -> + %% Client did not send ECC extension use default curve if + %% ECC cipher is negotiated + {namedCurve, ?secp256r1}. -renegotiation_info(_RecordCB, server, ConnectionStates, true) -> - ConnectionState = ssl_record:current_connection_state(ConnectionStates, read), - case maps:get(secure_renegotiation, ConnectionState) of - true -> - CData = maps:get(client_verify_data, ConnectionState), - SData = maps:get(server_verify_data, ConnectionState), - #renegotiation_info{renegotiated_connection = <<CData/binary, SData/binary>>}; - false -> - #renegotiation_info{renegotiated_connection = undefined} - end. +%%-------------------------------------------------------------------- +-spec select_hashsign(#hash_sign_algos{} | undefined, undefined | binary(), + atom(), [atom()], ssl_record:ssl_version()) -> + {atom(), atom()} | undefined | #alert{}. -handle_renegotiation_info(_RecordCB, _, #renegotiation_info{renegotiated_connection = ?byte(0)}, - ConnectionStates, false, _, _) -> - {ok, ssl_record:set_renegotiation_flag(true, ConnectionStates)}; +%% +%% Description: Handles signature_algorithms hello extension (server) +%%-------------------------------------------------------------------- +select_hashsign(_, undefined, _, _, _Version) -> + {null, anon}; +%% The signature_algorithms extension was introduced with TLS 1.2. Ignore it if we have +%% negotiated a lower version. +select_hashsign(HashSigns, Cert, KeyExAlgo, + undefined, {Major, Minor} = Version) when Major >= 3 andalso Minor >= 3-> + select_hashsign(HashSigns, Cert, KeyExAlgo, tls_v1:default_signature_algs(Version), Version); +select_hashsign(#hash_sign_algos{hash_sign_algos = HashSigns}, Cert, KeyExAlgo, SupportedHashSigns, + {Major, Minor}) when Major >= 3 andalso Minor >= 3 -> + #'OTPCertificate'{tbsCertificate = TBSCert, + signatureAlgorithm = {_,SignAlgo, _}} = public_key:pkix_decode_cert(Cert, otp), + #'OTPSubjectPublicKeyInfo'{algorithm = {_, SubjAlgo, _}} = + TBSCert#'OTPTBSCertificate'.subjectPublicKeyInfo, -handle_renegotiation_info(_RecordCB, server, undefined, ConnectionStates, _, _, CipherSuites) -> - case is_member(?TLS_EMPTY_RENEGOTIATION_INFO_SCSV, CipherSuites) of - true -> - {ok, ssl_record:set_renegotiation_flag(true, ConnectionStates)}; - false -> - {ok, ssl_record:set_renegotiation_flag(false, ConnectionStates)} + Sign = sign_algo(SignAlgo), + SubSing = sign_algo(SubjAlgo), + + case lists:filter(fun({_, S} = Algos) when S == Sign -> + is_acceptable_hash_sign(Algos, Sign, + SubSing, KeyExAlgo, SupportedHashSigns); + (_) -> + false + end, HashSigns) of + [] -> + ?ALERT_REC(?FATAL, ?INSUFFICIENT_SECURITY, no_suitable_signature_algorithm); + [HashSign | _] -> + HashSign end; +select_hashsign(_, Cert, _, _, Version) -> + #'OTPCertificate'{tbsCertificate = TBSCert} = public_key:pkix_decode_cert(Cert, otp), + #'OTPSubjectPublicKeyInfo'{algorithm = {_,Algo, _}} = TBSCert#'OTPTBSCertificate'.subjectPublicKeyInfo, + select_hashsign_algs(undefined, Algo, Version). +%%-------------------------------------------------------------------- +-spec select_hashsign(#certificate_request{}, binary(), + [atom()], ssl_record:ssl_version()) -> + {atom(), atom()} | #alert{}. -handle_renegotiation_info(_RecordCB, _, undefined, ConnectionStates, false, _, _) -> - {ok, ssl_record:set_renegotiation_flag(false, ConnectionStates)}; +%% +%% Description: Handles signature algorithms selection for certificate requests (client) +%%-------------------------------------------------------------------- +select_hashsign(#certificate_request{}, undefined, _, {Major, Minor}) when Major >= 3 andalso Minor >= 3-> + %% There client does not have a certificate and will send an empty reply, the server may fail + %% or accept the connection by its own preference. No signature algorihms needed as there is + %% no certificate to verify. + {undefined, undefined}; + +select_hashsign(#certificate_request{hashsign_algorithms = #hash_sign_algos{hash_sign_algos = HashSigns}, + certificate_types = Types}, Cert, SupportedHashSigns, + {Major, Minor}) when Major >= 3 andalso Minor >= 3-> + #'OTPCertificate'{tbsCertificate = TBSCert} = public_key:pkix_decode_cert(Cert, otp), + #'OTPCertificate'{tbsCertificate = TBSCert, + signatureAlgorithm = {_,SignAlgo, _}} = public_key:pkix_decode_cert(Cert, otp), + #'OTPSubjectPublicKeyInfo'{algorithm = {_, SubjAlgo, _}} = + TBSCert#'OTPTBSCertificate'.subjectPublicKeyInfo, -handle_renegotiation_info(_RecordCB, client, #renegotiation_info{renegotiated_connection = ClientServerVerify}, - ConnectionStates, true, _, _) -> - ConnectionState = ssl_record:current_connection_state(ConnectionStates, read), - CData = maps:get(client_verify_data, ConnectionState), - SData = maps:get(server_verify_data, ConnectionState), - case <<CData/binary, SData/binary>> == ClientServerVerify of + Sign = sign_algo(SignAlgo), + SubSign = sign_algo(SubjAlgo), + + case is_acceptable_cert_type(SubSign, HashSigns, Types) andalso is_supported_sign(Sign, HashSigns) of true -> - {ok, ConnectionStates}; + case lists:filter(fun({_, S} = Algos) when S == SubSign -> + is_acceptable_hash_sign(Algos, SupportedHashSigns); + (_) -> + false + end, HashSigns) of + [] -> + ?ALERT_REC(?FATAL, ?INSUFFICIENT_SECURITY, no_suitable_signature_algorithm); + [HashSign | _] -> + HashSign + end; false -> - ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, client_renegotiation) + ?ALERT_REC(?FATAL, ?INSUFFICIENT_SECURITY, no_suitable_signature_algorithm) end; -handle_renegotiation_info(_RecordCB, server, #renegotiation_info{renegotiated_connection = ClientVerify}, - ConnectionStates, true, _, CipherSuites) -> - - case is_member(?TLS_EMPTY_RENEGOTIATION_INFO_SCSV, CipherSuites) of - true -> - ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, {server_renegotiation, empty_renegotiation_info_scsv}); - false -> - ConnectionState = ssl_record:current_connection_state(ConnectionStates, read), - Data = maps:get(client_verify_data, ConnectionState), - case Data == ClientVerify of - true -> - {ok, ConnectionStates}; - false -> - ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, server_renegotiation) - end - end; - -handle_renegotiation_info(RecordCB, client, undefined, ConnectionStates, true, SecureRenegotation, _) -> - handle_renegotiation_info(RecordCB, ConnectionStates, SecureRenegotation); +select_hashsign(#certificate_request{}, Cert, _, Version) -> + select_hashsign(undefined, Cert, undefined, [], Version). -handle_renegotiation_info(RecordCB, server, undefined, ConnectionStates, true, SecureRenegotation, CipherSuites) -> - case is_member(?TLS_EMPTY_RENEGOTIATION_INFO_SCSV, CipherSuites) of - true -> - ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, {server_renegotiation, empty_renegotiation_info_scsv}); - false -> - handle_renegotiation_info(RecordCB, ConnectionStates, SecureRenegotation) - end. +%%-------------------------------------------------------------------- +-spec select_hashsign_algs({atom(), atom()}| undefined, oid(), ssl_record:ssl_version()) -> + {atom(), atom()}. -handle_renegotiation_info(_RecordCB, ConnectionStates, SecureRenegotation) -> - ConnectionState = ssl_record:current_connection_state(ConnectionStates, read), - case {SecureRenegotation, maps:get(secure_renegotiation, ConnectionState)} of - {_, true} -> - ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, already_secure); - {true, false} -> - ?ALERT_REC(?FATAL, ?NO_RENEGOTIATION); - {false, false} -> - {ok, ConnectionStates} - end. +%% Description: For TLS 1.2 hash function and signature algorithm pairs can be +%% negotiated with the signature_algorithms extension, +%% for previous versions always use appropriate defaults. +%% RFC 5246, Sect. 7.4.1.4.1. Signature Algorithms +%% If the client does not send the signature_algorithms extension, the +%% server MUST do the following: (e.i defaults for TLS 1.2) +%% +%% - If the negotiated key exchange algorithm is one of (RSA, DHE_RSA, +%% DH_RSA, RSA_PSK, ECDH_RSA, ECDHE_RSA), behave as if client had +%% sent the value {sha1,rsa}. +%% +%% - If the negotiated key exchange algorithm is one of (DHE_DSS, +%% DH_DSS), behave as if the client had sent the value {sha1,dsa}. +%% +%% - If the negotiated key exchange algorithm is one of (ECDH_ECDSA, +%% ECDHE_ECDSA), behave as if the client had sent value {sha1,ecdsa}. -hello_extensions_list(#hello_extensions{renegotiation_info = RenegotiationInfo, - srp = SRP, - signature_algs = HashSigns, - ec_point_formats = EcPointFormats, - elliptic_curves = EllipticCurves, - alpn = ALPN, - next_protocol_negotiation = NextProtocolNegotiation, - sni = Sni}) -> - [Ext || Ext <- [RenegotiationInfo, SRP, HashSigns, - EcPointFormats, EllipticCurves, ALPN, NextProtocolNegotiation, Sni], Ext =/= undefined]. +%%-------------------------------------------------------------------- +select_hashsign_algs(HashSign, _, {Major, Minor}) when HashSign =/= undefined andalso + Major >= 3 andalso Minor >= 3 -> + HashSign; +select_hashsign_algs(undefined, ?rsaEncryption, {Major, Minor}) when Major >= 3 andalso Minor >= 3 -> + {sha, rsa}; +select_hashsign_algs(undefined,?'id-ecPublicKey', _) -> + {sha, ecdsa}; +select_hashsign_algs(undefined, ?rsaEncryption, _) -> + {md5sha, rsa}; +select_hashsign_algs(undefined, ?'id-dsa', _) -> + {sha, dsa}. srp_user(#ssl_options{srp_identity = {UserName, _}}) -> #srp{username = UserName}; srp_user(_) -> undefined. -client_ecc_extensions(SupportedECCs) -> - CryptoSupport = proplists:get_value(public_keys, crypto:supports()), - case proplists:get_bool(ecdh, CryptoSupport) of - true -> - EcPointFormats = #ec_point_formats{ec_point_format_list = [?ECPOINT_UNCOMPRESSED]}, - EllipticCurves = SupportedECCs, - {EcPointFormats, EllipticCurves}; - _ -> - {undefined, undefined} - end. +%%-------------------------------------------------------------------- +%%% Internal functions +%%-------------------------------------------------------------------- +%%------------- Create handshake messages ---------------------------- -server_ecc_extension(_Version, EcPointFormats) -> - CryptoSupport = proplists:get_value(public_keys, crypto:supports()), - case proplists:get_bool(ecdh, CryptoSupport) of +int_to_bin(I) -> + L = (length(integer_to_list(I, 16)) + 1) div 2, + <<I:(L*8)>>. + +certificate_types(_, {N, M}) when N >= 3 andalso M >= 3 -> + case proplists:get_bool(ecdsa, + proplists:get_value(public_keys, crypto:supports())) of true -> - handle_ecc_point_fmt_extension(EcPointFormats); + <<?BYTE(?ECDSA_SIGN), ?BYTE(?RSA_SIGN), ?BYTE(?DSS_SIGN)>>; false -> - undefined - end. - -handle_ecc_point_fmt_extension(undefined) -> - undefined; -handle_ecc_point_fmt_extension(_) -> - #ec_point_formats{ec_point_format_list = [?ECPOINT_UNCOMPRESSED]}. + <<?BYTE(?RSA_SIGN), ?BYTE(?DSS_SIGN)>> + end; -advertises_ec_ciphers([]) -> - false; -advertises_ec_ciphers([{ecdh_ecdsa, _,_,_} | _]) -> - true; -advertises_ec_ciphers([{ecdhe_ecdsa, _,_,_} | _]) -> - true; -advertises_ec_ciphers([{ecdh_rsa, _,_,_} | _]) -> - true; -advertises_ec_ciphers([{ecdhe_rsa, _,_,_} | _]) -> - true; -advertises_ec_ciphers([{ecdh_anon, _,_,_} | _]) -> - true; -advertises_ec_ciphers([{ecdhe_psk, _,_,_} | _]) -> - true; -advertises_ec_ciphers([_| Rest]) -> - advertises_ec_ciphers(Rest). +certificate_types(#{key_exchange := KeyExchange}, _) when KeyExchange == rsa; + KeyExchange == dh_rsa; + KeyExchange == dhe_rsa; + KeyExchange == ecdhe_rsa -> + <<?BYTE(?RSA_SIGN)>>; -select_curve(Client, Server) -> - select_curve(Client, Server, false). +certificate_types(#{key_exchange := KeyExchange}, _) when KeyExchange == dh_dss; + KeyExchange == dhe_dss; + KeyExchange == srp_dss -> + <<?BYTE(?DSS_SIGN)>>; -select_curve(#elliptic_curves{elliptic_curve_list = ClientCurves}, - #elliptic_curves{elliptic_curve_list = ServerCurves}, - ServerOrder) -> - case ServerOrder of - false -> - select_shared_curve(ClientCurves, ServerCurves); - true -> - select_shared_curve(ServerCurves, ClientCurves) - end; -select_curve(undefined, _, _) -> - %% Client did not send ECC extension use default curve if - %% ECC cipher is negotiated - {namedCurve, ?secp256r1}. +certificate_types(#{key_exchange := KeyExchange}, _) when KeyExchange == dh_ecdsa; + KeyExchange == dhe_ecdsa; + KeyExchange == ecdh_ecdsa; + KeyExchange == ecdhe_ecdsa -> + <<?BYTE(?ECDSA_SIGN)>>; +certificate_types(_, _) -> + <<?BYTE(?RSA_SIGN)>>. -select_shared_curve([], _) -> - no_curve; -select_shared_curve([Curve | Rest], Curves) -> - case lists:member(Curve, Curves) of - true -> - {namedCurve, Curve}; - false -> - select_shared_curve(Rest, Curves) - end. +certificate_authorities(CertDbHandle, CertDbRef) -> + Authorities = certificate_authorities_from_db(CertDbHandle, CertDbRef), + Enc = fun(#'OTPCertificate'{tbsCertificate=TBSCert}) -> + OTPSubj = TBSCert#'OTPTBSCertificate'.subject, + DNEncodedBin = public_key:pkix_encode('Name', OTPSubj, otp), + DNEncodedLen = byte_size(DNEncodedBin), + <<?UINT16(DNEncodedLen), DNEncodedBin/binary>> + end, + list_to_binary([Enc(Cert) || {_, Cert} <- Authorities]). -sni(undefined) -> - undefined; -sni(disable) -> - undefined; -sni(Hostname) -> - #sni{hostname = Hostname}. +certificate_authorities_from_db(CertDbHandle, CertDbRef) when is_reference(CertDbRef) -> + ConnectionCerts = fun({{Ref, _, _}, Cert}, Acc) when Ref == CertDbRef -> + [Cert | Acc]; + (_, Acc) -> + Acc + end, + ssl_pkix_db:foldl(ConnectionCerts, [], CertDbHandle); +certificate_authorities_from_db(_CertDbHandle, {extracted, CertDbData}) -> + %% Cache disabled, Ref contains data + lists:foldl(fun({decoded, {_Key,Cert}}, Acc) -> [Cert | Acc] end, + [], CertDbData). -%%-------------------------------------------------------------------- -%%% Internal functions -%%-------------------------------------------------------------------- +%%-------------Handle handshake messages -------------------------------- validation_fun_and_state({Fun, UserState0}, Role, CertDbHandle, CertDbRef, ServerNameIndication, CRLCheck, CRLDbHandle, CertPath) -> {fun(OtpCert, {extension, _} = Extension, {SslState, UserState}) -> @@ -1683,17 +1322,6 @@ path_validation_alert({bad_cert, unknown_ca}) -> path_validation_alert(Reason) -> ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, Reason). -encrypted_premaster_secret(Secret, RSAPublicKey) -> - try - PreMasterSecret = public_key:encrypt_public(Secret, RSAPublicKey, - [{rsa_pad, - rsa_pkcs1_padding}]), - #encrypted_premaster_secret{premaster_secret = PreMasterSecret} - catch - _:_-> - throw(?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, premaster_encryption_failed)) - end. - digitally_signed(Version, Hashes, HashAlgo, PrivateKey) -> try do_digitally_signed(Version, Hashes, HashAlgo, PrivateKey) of Signature -> @@ -1702,17 +1330,123 @@ digitally_signed(Version, Hashes, HashAlgo, PrivateKey) -> error:badkey-> throw(?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, bad_key(PrivateKey))) end. - +do_digitally_signed({3, Minor}, Hash, HashAlgo, #{algorithm := Alg} = Engine) + when Minor >= 3 -> + crypto:sign(Alg, HashAlgo, {digest, Hash}, maps:remove(algorithm, Engine)); do_digitally_signed({3, Minor}, Hash, HashAlgo, Key) when Minor >= 3 -> public_key:sign({digest, Hash}, HashAlgo, Key); -do_digitally_signed(_Version, Hash, HashAlgo, #'DSAPrivateKey'{} = Key) -> - public_key:sign({digest, Hash}, HashAlgo, Key); do_digitally_signed(_Version, Hash, _HashAlgo, #'RSAPrivateKey'{} = Key) -> public_key:encrypt_private(Hash, Key, [{rsa_pad, rsa_pkcs1_padding}]); +do_digitally_signed({3, _}, Hash, _, + #{algorithm := rsa} = Engine) -> + crypto:private_encrypt(rsa, Hash, maps:remove(algorithm, Engine), + rsa_pkcs1_padding); +do_digitally_signed({3, _}, Hash, HashAlgo, #{algorithm := Alg} = Engine) -> + crypto:sign(Alg, HashAlgo, {digest, Hash}, maps:remove(algorithm, Engine)); do_digitally_signed(_Version, Hash, HashAlgo, Key) -> public_key:sign({digest, Hash}, HashAlgo, Key). +bad_key(#'DSAPrivateKey'{}) -> + unacceptable_dsa_key; +bad_key(#'RSAPrivateKey'{}) -> + unacceptable_rsa_key; +bad_key(#'ECPrivateKey'{}) -> + unacceptable_ecdsa_key. + +crl_check(_, false, _,_,_, _, _) -> + valid; +crl_check(_, peer, _, _,_, valid, _) -> %% Do not check CAs with this option. + valid; +crl_check(OtpCert, Check, CertDbHandle, CertDbRef, {Callback, CRLDbHandle}, _, CertPath) -> + Options = [{issuer_fun, {fun(_DP, CRL, Issuer, DBInfo) -> + ssl_crl:trusted_cert_and_path(CRL, Issuer, {CertPath, + DBInfo}) + end, {CertDbHandle, CertDbRef}}}, + {update_crl, fun(DP, CRL) -> Callback:fresh_crl(DP, CRL) end}, + {undetermined_details, true} + ], + case dps_and_crls(OtpCert, Callback, CRLDbHandle, ext) of + no_dps -> + crl_check_same_issuer(OtpCert, Check, + dps_and_crls(OtpCert, Callback, CRLDbHandle, same_issuer), + Options); + DpsAndCRLs -> %% This DP list may be empty if relevant CRLs existed + %% but could not be retrived, will result in {bad_cert, revocation_status_undetermined} + case public_key:pkix_crls_validate(OtpCert, DpsAndCRLs, Options) of + {bad_cert, {revocation_status_undetermined, _}} -> + crl_check_same_issuer(OtpCert, Check, dps_and_crls(OtpCert, Callback, + CRLDbHandle, same_issuer), Options); + Other -> + Other + end + end. + +crl_check_same_issuer(OtpCert, best_effort, Dps, Options) -> + case public_key:pkix_crls_validate(OtpCert, Dps, Options) of + {bad_cert, {revocation_status_undetermined, _}} -> + valid; + Other -> + Other + end; +crl_check_same_issuer(OtpCert, _, Dps, Options) -> + public_key:pkix_crls_validate(OtpCert, Dps, Options). + +dps_and_crls(OtpCert, Callback, CRLDbHandle, ext) -> + case public_key:pkix_dist_points(OtpCert) of + [] -> + no_dps; + DistPoints -> + Issuer = OtpCert#'OTPCertificate'.tbsCertificate#'OTPTBSCertificate'.issuer, + CRLs = distpoints_lookup(DistPoints, Issuer, Callback, CRLDbHandle), + dps_and_crls(DistPoints, CRLs, []) + end; + +dps_and_crls(OtpCert, Callback, CRLDbHandle, same_issuer) -> + DP = #'DistributionPoint'{distributionPoint = {fullName, GenNames}} = + public_key:pkix_dist_point(OtpCert), + CRLs = lists:flatmap(fun({directoryName, Issuer}) -> + Callback:select(Issuer, CRLDbHandle); + (_) -> + [] + end, GenNames), + [{DP, {CRL, public_key:der_decode('CertificateList', CRL)}} || CRL <- CRLs]. + +dps_and_crls([], _, Acc) -> + Acc; +dps_and_crls([DP | Rest], CRLs, Acc) -> + DpCRL = [{DP, {CRL, public_key:der_decode('CertificateList', CRL)}} || CRL <- CRLs], + dps_and_crls(Rest, CRLs, DpCRL ++ Acc). + +distpoints_lookup([],_, _, _) -> + []; +distpoints_lookup([DistPoint | Rest], Issuer, Callback, CRLDbHandle) -> + Result = + try Callback:lookup(DistPoint, Issuer, CRLDbHandle) + catch + error:undef -> + %% The callback module still uses the 2-argument + %% version of the lookup function. + Callback:lookup(DistPoint, CRLDbHandle) + end, + case Result of + not_available -> + distpoints_lookup(Rest, Issuer, Callback, CRLDbHandle); + CRLs -> + CRLs + end. + +encrypted_premaster_secret(Secret, RSAPublicKey) -> + try + PreMasterSecret = public_key:encrypt_public(Secret, RSAPublicKey, + [{rsa_pad, + rsa_pkcs1_padding}]), + #encrypted_premaster_secret{premaster_secret = PreMasterSecret} + catch + _:_-> + throw(?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, premaster_encryption_failed)) + end. + calc_certificate_verify({3, 0}, HashAlgo, MasterSecret, Handshake) -> ssl_v3:certificate_verify(HashAlgo, MasterSecret, lists:reverse(Handshake)); calc_certificate_verify({3, N}, HashAlgo, _MasterSecret, Handshake) -> @@ -1765,24 +1499,7 @@ calc_master_secret({3,0}, _PrfAlgo, PremasterSecret, ClientRandom, ServerRandom) calc_master_secret({3,_}, PrfAlgo, PremasterSecret, ClientRandom, ServerRandom) -> tls_v1:master_secret(PrfAlgo, PremasterSecret, ClientRandom, ServerRandom). - -handle_renegotiation_extension(Role, RecordCB, Version, Info, Random, NegotiatedCipherSuite, - ClientCipherSuites, Compression, - ConnectionStates0, Renegotiation, SecureRenegotation) -> - case handle_renegotiation_info(RecordCB, Role, Info, ConnectionStates0, - Renegotiation, SecureRenegotation, - ClientCipherSuites) of - {ok, ConnectionStates} -> - hello_pending_connection_states(RecordCB, Role, - Version, - NegotiatedCipherSuite, - Random, - Compression, - ConnectionStates); - #alert{} = Alert -> - throw(Alert) - end. - + %% Update pending connection states with parameters exchanged via %% hello messages %% NOTE : Role is the role of the receiver of the hello message @@ -1822,7 +1539,43 @@ hello_security_parameters(server, Version, #{security_parameters := SecParams}, compression_algorithm = Compression }. -%%-------------Encode/Decode -------------------------------- +select_compression(_CompressionMetodes) -> + ?NULL. + +do_select_version(_, ClientVersion, []) -> + ClientVersion; +do_select_version(RecordCB, ClientVersion, [Version | Versions]) -> + case RecordCB:is_higher(Version, ClientVersion) of + true -> + %% Version too high for client - keep looking + do_select_version(RecordCB, ClientVersion, Versions); + false -> + %% Version ok for client - look for a higher + do_select_version(RecordCB, ClientVersion, Versions, Version) + end. +%% +do_select_version(_, _, [], GoodVersion) -> + GoodVersion; +do_select_version( + RecordCB, ClientVersion, [Version | Versions], GoodVersion) -> + BetterVersion = + case RecordCB:is_higher(Version, ClientVersion) of + true -> + %% Version too high for client + GoodVersion; + false -> + %% Version ok for client + case RecordCB:is_higher(Version, GoodVersion) of + true -> + %% Use higher version + Version; + false -> + GoodVersion + end + end, + do_select_version(RecordCB, ClientVersion, Versions, BetterVersion). + +%%-------------Encode handshakes -------------------------------- encode_server_key(#server_dh_params{dh_p = P, dh_g = G, dh_y = Y}) -> PLen = byte_size(P), @@ -1928,6 +1681,126 @@ encode_protocol(Protocol, Acc) -> Len = byte_size(Protocol), <<Acc/binary, ?BYTE(Len), Protocol/binary>>. +enc_server_key_exchange(Version, Params, {HashAlgo, SignAlgo}, + ClientRandom, ServerRandom, PrivateKey) -> + EncParams = encode_server_key(Params), + case HashAlgo of + null -> + #server_key_params{params = Params, + params_bin = EncParams, + hashsign = {null, anon}, + signature = <<>>}; + _ -> + Hash = + server_key_exchange_hash(HashAlgo, <<ClientRandom/binary, + ServerRandom/binary, + EncParams/binary>>), + Signature = digitally_signed(Version, Hash, HashAlgo, PrivateKey), + #server_key_params{params = Params, + params_bin = EncParams, + hashsign = {HashAlgo, SignAlgo}, + signature = Signature} + end. + +%% While the RFC opens the door to allow ALPN during renegotiation, in practice +%% this does not work and it is recommended to ignore any ALPN extension during +%% renegotiation, as done here. +encode_alpn(_, true) -> + undefined; +encode_alpn(undefined, _) -> + undefined; +encode_alpn(Protocols, _) -> + #alpn{extension_data = lists:foldl(fun encode_protocol/2, <<>>, Protocols)}. + +hello_extensions_list(#hello_extensions{renegotiation_info = RenegotiationInfo, + srp = SRP, + signature_algs = HashSigns, + ec_point_formats = EcPointFormats, + elliptic_curves = EllipticCurves, + alpn = ALPN, + next_protocol_negotiation = NextProtocolNegotiation, + sni = Sni}) -> + [Ext || Ext <- [RenegotiationInfo, SRP, HashSigns, + EcPointFormats, EllipticCurves, ALPN, NextProtocolNegotiation, Sni], Ext =/= undefined]. + +%%-------------Decode handshakes--------------------------------- +dec_server_key(<<?UINT16(PLen), P:PLen/binary, + ?UINT16(GLen), G:GLen/binary, + ?UINT16(YLen), Y:YLen/binary, _/binary>> = KeyStruct, + ?KEY_EXCHANGE_DIFFIE_HELLMAN, Version) -> + Params = #server_dh_params{dh_p = P, dh_g = G, dh_y = Y}, + {BinMsg, HashSign, Signature} = dec_server_key_params(PLen + GLen + YLen + 6, KeyStruct, Version), + #server_key_params{params = Params, + params_bin = BinMsg, + hashsign = HashSign, + signature = Signature}; +%% ECParameters with named_curve +%% TODO: explicit curve +dec_server_key(<<?BYTE(?NAMED_CURVE), ?UINT16(CurveID), + ?BYTE(PointLen), ECPoint:PointLen/binary, + _/binary>> = KeyStruct, + ?KEY_EXCHANGE_EC_DIFFIE_HELLMAN, Version) -> + Params = #server_ecdh_params{curve = {namedCurve, tls_v1:enum_to_oid(CurveID)}, + public = ECPoint}, + {BinMsg, HashSign, Signature} = dec_server_key_params(PointLen + 4, KeyStruct, Version), + #server_key_params{params = Params, + params_bin = BinMsg, + hashsign = HashSign, + signature = Signature}; +dec_server_key(<<?UINT16(Len), PskIdentityHint:Len/binary, _/binary>> = KeyStruct, + KeyExchange, Version) + when KeyExchange == ?KEY_EXCHANGE_PSK; KeyExchange == ?KEY_EXCHANGE_RSA_PSK -> + Params = #server_psk_params{ + hint = PskIdentityHint}, + {BinMsg, HashSign, Signature} = dec_server_key_params(Len + 2, KeyStruct, Version), + #server_key_params{params = Params, + params_bin = BinMsg, + hashsign = HashSign, + signature = Signature}; +dec_server_key(<<?UINT16(Len), IdentityHint:Len/binary, + ?UINT16(PLen), P:PLen/binary, + ?UINT16(GLen), G:GLen/binary, + ?UINT16(YLen), Y:YLen/binary, _/binary>> = KeyStruct, + ?KEY_EXCHANGE_DHE_PSK, Version) -> + DHParams = #server_dh_params{dh_p = P, dh_g = G, dh_y = Y}, + Params = #server_dhe_psk_params{ + hint = IdentityHint, + dh_params = DHParams}, + {BinMsg, HashSign, Signature} = dec_server_key_params(Len + PLen + GLen + YLen + 8, KeyStruct, Version), + #server_key_params{params = Params, + params_bin = BinMsg, + hashsign = HashSign, + signature = Signature}; +dec_server_key(<<?UINT16(Len), IdentityHint:Len/binary, + ?BYTE(?NAMED_CURVE), ?UINT16(CurveID), + ?BYTE(PointLen), ECPoint:PointLen/binary, + _/binary>> = KeyStruct, + ?KEY_EXCHANGE_EC_DIFFIE_HELLMAN_PSK, Version) -> + DHParams = #server_ecdh_params{ + curve = {namedCurve, tls_v1:enum_to_oid(CurveID)}, + public = ECPoint}, + Params = #server_ecdhe_psk_params{ + hint = IdentityHint, + dh_params = DHParams}, + {BinMsg, HashSign, Signature} = dec_server_key_params(Len + 2 + PointLen + 4, KeyStruct, Version), + #server_key_params{params = Params, + params_bin = BinMsg, + hashsign = HashSign, + signature = Signature}; +dec_server_key(<<?UINT16(NLen), N:NLen/binary, + ?UINT16(GLen), G:GLen/binary, + ?BYTE(SLen), S:SLen/binary, + ?UINT16(BLen), B:BLen/binary, _/binary>> = KeyStruct, + ?KEY_EXCHANGE_SRP, Version) -> + Params = #server_srp_params{srp_n = N, srp_g = G, srp_s = S, srp_b = B}, + {BinMsg, HashSign, Signature} = dec_server_key_params(NLen + GLen + SLen + BLen + 7, KeyStruct, Version), + #server_key_params{params = Params, + params_bin = BinMsg, + hashsign = HashSign, + signature = Signature}; +dec_server_key(_, KeyExchange, _) -> + throw(?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, {unknown_or_malformed_key_exchange, KeyExchange})). + dec_client_key(PKEPMS, ?KEY_EXCHANGE_RSA, {3, 0}) -> #encrypted_premaster_secret{premaster_secret = PKEPMS}; dec_client_key(<<?UINT16(_), PKEPMS/binary>>, ?KEY_EXCHANGE_RSA, _) -> @@ -2073,6 +1946,11 @@ dec_sni(<<?BYTE(?SNI_NAMETYPE_HOST_NAME), ?UINT16(Len), dec_sni(<<?BYTE(_), ?UINT16(Len), _:Len, Rest/binary>>) -> dec_sni(Rest); dec_sni(_) -> undefined. +decode_alpn(undefined) -> + undefined; +decode_alpn(#alpn{extension_data=Data}) -> + decode_protocols(Data, []). + decode_next_protocols({next_protocol_negotiation, Protocols}) -> decode_protocols(Protocols, []). @@ -2117,6 +1995,7 @@ from_2bytes(<<>>, Acc) -> lists:reverse(Acc); from_2bytes(<<?UINT16(N), Rest/binary>>, Acc) -> from_2bytes(Rest, [?uint16(N) | Acc]). + key_exchange_alg(rsa) -> ?KEY_EXCHANGE_RSA; key_exchange_alg(Alg) when Alg == dhe_rsa; Alg == dhe_dss; @@ -2140,8 +2019,123 @@ key_exchange_alg(Alg) key_exchange_alg(_) -> ?NULL. +%%-------------Cipher suite handling ----------------------------- +select_cipher_suite(CipherSuites, Suites, false) -> + select_cipher_suite(CipherSuites, Suites); +select_cipher_suite(CipherSuites, Suites, true) -> + select_cipher_suite(Suites, CipherSuites). + +select_cipher_suite([], _) -> + no_suite; +select_cipher_suite([Suite | ClientSuites], SupportedSuites) -> + case is_member(Suite, SupportedSuites) of + true -> + Suite; + false -> + select_cipher_suite(ClientSuites, SupportedSuites) + end. + +is_member(Suite, SupportedSuites) -> + lists:member(Suite, SupportedSuites). + +psk_secret(PSKIdentity, PSKLookup) -> + case handle_psk_identity(PSKIdentity, PSKLookup) of + {ok, PSK} when is_binary(PSK) -> + Len = erlang:byte_size(PSK), + <<?UINT16(Len), 0:(Len*8), ?UINT16(Len), PSK/binary>>; + #alert{} = Alert -> + Alert; + _ -> + throw(?ALERT_REC(?FATAL, ?ILLEGAL_PARAMETER)) + end. + +psk_secret(PSKIdentity, PSKLookup, PremasterSecret) -> + case handle_psk_identity(PSKIdentity, PSKLookup) of + {ok, PSK} when is_binary(PSK) -> + Len = erlang:byte_size(PremasterSecret), + PSKLen = erlang:byte_size(PSK), + <<?UINT16(Len), PremasterSecret/binary, ?UINT16(PSKLen), PSK/binary>>; + #alert{} = Alert -> + Alert; + _ -> + throw(?ALERT_REC(?FATAL, ?ILLEGAL_PARAMETER)) + end. + +handle_psk_identity(_PSKIdentity, LookupFun) + when LookupFun == undefined -> + error; +handle_psk_identity(PSKIdentity, {Fun, UserState}) -> + Fun(psk, PSKIdentity, UserState). + +filter_hashsigns([], [], _, Acc) -> + lists:reverse(Acc); +filter_hashsigns([Suite | Suites], [#{key_exchange := KeyExchange} | Algos], HashSigns, + Acc) when KeyExchange == dhe_ecdsa; + KeyExchange == ecdhe_ecdsa -> + do_filter_hashsigns(ecdsa, Suite, Suites, Algos, HashSigns, Acc); + +filter_hashsigns([Suite | Suites], [#{key_exchange := KeyExchange} | Algos], HashSigns, + Acc) when KeyExchange == rsa; + KeyExchange == dhe_rsa; + KeyExchange == ecdhe_rsa; + KeyExchange == srp_rsa; + KeyExchange == rsa_psk -> + do_filter_hashsigns(rsa, Suite, Suites, Algos, HashSigns, Acc); +filter_hashsigns([Suite | Suites], [#{key_exchange := KeyExchange} | Algos], HashSigns, Acc) when + KeyExchange == dhe_dss; + KeyExchange == srp_dss -> + do_filter_hashsigns(dsa, Suite, Suites, Algos, HashSigns, Acc); +filter_hashsigns([Suite | Suites], [#{key_exchange := KeyExchange} | Algos], HashSigns, Acc) when + KeyExchange == dh_dss; + KeyExchange == dh_rsa; + KeyExchange == dh_ecdsa; + KeyExchange == ecdh_rsa; + KeyExchange == ecdh_ecdsa -> + %% Fixed DH certificates MAY be signed with any hash/signature + %% algorithm pair appearing in the hash_sign extension. The names + %% DH_DSS, DH_RSA, ECDH_ECDSA, and ECDH_RSA are historical. + filter_hashsigns(Suites, Algos, HashSigns, [Suite| Acc]); +filter_hashsigns([Suite | Suites], [#{key_exchange := KeyExchange} | Algos], HashSigns, Acc) when + KeyExchange == dh_anon; + KeyExchange == ecdh_anon; + KeyExchange == srp_anon; + KeyExchange == psk; + KeyExchange == dhe_psk; + KeyExchange == ecdhe_psk -> + %% In this case hashsigns is not used as the kexchange is anonaymous + filter_hashsigns(Suites, Algos, HashSigns, [Suite| Acc]). + +do_filter_hashsigns(SignAlgo, Suite, Suites, Algos, HashSigns, Acc) -> + case lists:keymember(SignAlgo, 2, HashSigns) of + true -> + filter_hashsigns(Suites, Algos, HashSigns, [Suite| Acc]); + false -> + filter_hashsigns(Suites, Algos, HashSigns, Acc) + end. + +unavailable_ecc_suites(no_curve) -> + ssl_cipher:ec_keyed_suites(); +unavailable_ecc_suites(_) -> + []. %%-------------Extension handling -------------------------------- +handle_renegotiation_extension(Role, RecordCB, Version, Info, Random, NegotiatedCipherSuite, + ClientCipherSuites, Compression, + ConnectionStates0, Renegotiation, SecureRenegotation) -> + case handle_renegotiation_info(RecordCB, Role, Info, ConnectionStates0, + Renegotiation, SecureRenegotation, + ClientCipherSuites) of + {ok, ConnectionStates} -> + hello_pending_connection_states(RecordCB, Role, + Version, + NegotiatedCipherSuite, + Random, + Compression, + ConnectionStates); + #alert{} = Alert -> + throw(Alert) + end. + %% Receive protocols, choose one from the list, return it. handle_alpn_extension(_, {error, Reason}) -> ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, Reason); @@ -2204,150 +2198,6 @@ handle_srp_extension(undefined, Session) -> handle_srp_extension(#srp{username = Username}, Session) -> Session#session{srp_username = Username}. -%%-------------Misc -------------------------------- - -select_cipher_suite(CipherSuites, Suites, false) -> - select_cipher_suite(CipherSuites, Suites); -select_cipher_suite(CipherSuites, Suites, true) -> - select_cipher_suite(Suites, CipherSuites). - -select_cipher_suite([], _) -> - no_suite; -select_cipher_suite([Suite | ClientSuites], SupportedSuites) -> - case is_member(Suite, SupportedSuites) of - true -> - Suite; - false -> - select_cipher_suite(ClientSuites, SupportedSuites) - end. - -int_to_bin(I) -> - L = (length(integer_to_list(I, 16)) + 1) div 2, - <<I:(L*8)>>. - -is_member(Suite, SupportedSuites) -> - lists:member(Suite, SupportedSuites). - -select_compression(_CompressionMetodes) -> - ?NULL. - -available_signature_algs(undefined, _) -> - undefined; -available_signature_algs(SupportedHashSigns, Version) when Version >= {3, 3} -> - #hash_sign_algos{hash_sign_algos = SupportedHashSigns}; -available_signature_algs(_, _) -> - undefined. - -psk_secret(PSKIdentity, PSKLookup) -> - case handle_psk_identity(PSKIdentity, PSKLookup) of - {ok, PSK} when is_binary(PSK) -> - Len = erlang:byte_size(PSK), - <<?UINT16(Len), 0:(Len*8), ?UINT16(Len), PSK/binary>>; - #alert{} = Alert -> - Alert; - _ -> - throw(?ALERT_REC(?FATAL, ?ILLEGAL_PARAMETER)) - end. - -psk_secret(PSKIdentity, PSKLookup, PremasterSecret) -> - case handle_psk_identity(PSKIdentity, PSKLookup) of - {ok, PSK} when is_binary(PSK) -> - Len = erlang:byte_size(PremasterSecret), - PSKLen = erlang:byte_size(PSK), - <<?UINT16(Len), PremasterSecret/binary, ?UINT16(PSKLen), PSK/binary>>; - #alert{} = Alert -> - Alert; - _ -> - throw(?ALERT_REC(?FATAL, ?ILLEGAL_PARAMETER)) - end. - -handle_psk_identity(_PSKIdentity, LookupFun) - when LookupFun == undefined -> - error; -handle_psk_identity(PSKIdentity, {Fun, UserState}) -> - Fun(psk, PSKIdentity, UserState). - -crl_check(_, false, _,_,_, _, _) -> - valid; -crl_check(_, peer, _, _,_, valid, _) -> %% Do not check CAs with this option. - valid; -crl_check(OtpCert, Check, CertDbHandle, CertDbRef, {Callback, CRLDbHandle}, _, CertPath) -> - Options = [{issuer_fun, {fun(_DP, CRL, Issuer, DBInfo) -> - ssl_crl:trusted_cert_and_path(CRL, Issuer, {CertPath, - DBInfo}) - end, {CertDbHandle, CertDbRef}}}, - {update_crl, fun(DP, CRL) -> Callback:fresh_crl(DP, CRL) end}, - {undetermined_details, true} - ], - case dps_and_crls(OtpCert, Callback, CRLDbHandle, ext) of - no_dps -> - crl_check_same_issuer(OtpCert, Check, - dps_and_crls(OtpCert, Callback, CRLDbHandle, same_issuer), - Options); - DpsAndCRLs -> %% This DP list may be empty if relevant CRLs existed - %% but could not be retrived, will result in {bad_cert, revocation_status_undetermined} - case public_key:pkix_crls_validate(OtpCert, DpsAndCRLs, Options) of - {bad_cert, {revocation_status_undetermined, _}} -> - crl_check_same_issuer(OtpCert, Check, dps_and_crls(OtpCert, Callback, - CRLDbHandle, same_issuer), Options); - Other -> - Other - end - end. - -crl_check_same_issuer(OtpCert, best_effort, Dps, Options) -> - case public_key:pkix_crls_validate(OtpCert, Dps, Options) of - {bad_cert, {revocation_status_undetermined, _}} -> - valid; - Other -> - Other - end; -crl_check_same_issuer(OtpCert, _, Dps, Options) -> - public_key:pkix_crls_validate(OtpCert, Dps, Options). - -dps_and_crls(OtpCert, Callback, CRLDbHandle, ext) -> - case public_key:pkix_dist_points(OtpCert) of - [] -> - no_dps; - DistPoints -> - Issuer = OtpCert#'OTPCertificate'.tbsCertificate#'OTPTBSCertificate'.issuer, - CRLs = distpoints_lookup(DistPoints, Issuer, Callback, CRLDbHandle), - dps_and_crls(DistPoints, CRLs, []) - end; - -dps_and_crls(OtpCert, Callback, CRLDbHandle, same_issuer) -> - DP = #'DistributionPoint'{distributionPoint = {fullName, GenNames}} = - public_key:pkix_dist_point(OtpCert), - CRLs = lists:flatmap(fun({directoryName, Issuer}) -> - Callback:select(Issuer, CRLDbHandle); - (_) -> - [] - end, GenNames), - [{DP, {CRL, public_key:der_decode('CertificateList', CRL)}} || CRL <- CRLs]. - -dps_and_crls([], _, Acc) -> - Acc; -dps_and_crls([DP | Rest], CRLs, Acc) -> - DpCRL = [{DP, {CRL, public_key:der_decode('CertificateList', CRL)}} || CRL <- CRLs], - dps_and_crls(Rest, CRLs, DpCRL ++ Acc). - -distpoints_lookup([],_, _, _) -> - []; -distpoints_lookup([DistPoint | Rest], Issuer, Callback, CRLDbHandle) -> - Result = - try Callback:lookup(DistPoint, Issuer, CRLDbHandle) - catch - error:undef -> - %% The callback module still uses the 2-argument - %% version of the lookup function. - Callback:lookup(DistPoint, CRLDbHandle) - end, - case Result of - not_available -> - distpoints_lookup(Rest, Issuer, Callback, CRLDbHandle); - CRLs -> - CRLs - end. sign_algo(?rsaEncryption) -> rsa; @@ -2398,7 +2248,6 @@ is_acceptable_hash_sign(_, _, _, KeyExAlgo, _) when true; is_acceptable_hash_sign(_,_, _,_,_) -> false. - is_acceptable_hash_sign(Algos, SupportedHashSigns) -> lists:member(Algos, SupportedHashSigns). @@ -2418,27 +2267,164 @@ sign_type(dsa) -> sign_type(ecdsa) -> ?ECDSA_SIGN. - -bad_key(#'DSAPrivateKey'{}) -> - unacceptable_dsa_key; -bad_key(#'RSAPrivateKey'{}) -> - unacceptable_rsa_key; -bad_key(#'ECPrivateKey'{}) -> - unacceptable_ecdsa_key. - -available_signature_algs(undefined, SupportedHashSigns, _, Version) when - Version >= {3,3} -> - SupportedHashSigns; -available_signature_algs(#hash_sign_algos{hash_sign_algos = ClientHashSigns}, SupportedHashSigns, - _, Version) when Version >= {3,3} -> - sets:to_list(sets:intersection(sets:from_list(ClientHashSigns), - sets:from_list(SupportedHashSigns))); -available_signature_algs(_, _, _, _) -> - undefined. - server_name(_, _, server) -> undefined; %% Not interesting to check your own name. server_name(undefined, Host, client) -> {fallback, Host}; %% Fallback to Host argument to connect server_name(SNI, _, client) -> SNI. %% If Server Name Indication is available + +client_ecc_extensions(SupportedECCs) -> + CryptoSupport = proplists:get_value(public_keys, crypto:supports()), + case proplists:get_bool(ecdh, CryptoSupport) of + true -> + EcPointFormats = #ec_point_formats{ec_point_format_list = [?ECPOINT_UNCOMPRESSED]}, + EllipticCurves = SupportedECCs, + {EcPointFormats, EllipticCurves}; + _ -> + {undefined, undefined} + end. + +server_ecc_extension(_Version, EcPointFormats) -> + CryptoSupport = proplists:get_value(public_keys, crypto:supports()), + case proplists:get_bool(ecdh, CryptoSupport) of + true -> + handle_ecc_point_fmt_extension(EcPointFormats); + false -> + undefined + end. + +handle_ecc_point_fmt_extension(undefined) -> + undefined; +handle_ecc_point_fmt_extension(_) -> + #ec_point_formats{ec_point_format_list = [?ECPOINT_UNCOMPRESSED]}. + +advertises_ec_ciphers([]) -> + false; +advertises_ec_ciphers([#{key_exchange := ecdh_ecdsa} | _]) -> + true; +advertises_ec_ciphers([#{key_exchange := ecdhe_ecdsa} | _]) -> + true; +advertises_ec_ciphers([#{key_exchange := ecdh_rsa} | _]) -> + true; +advertises_ec_ciphers([#{key_exchange := ecdhe_rsa} | _]) -> + true; +advertises_ec_ciphers([#{key_exchange := ecdh_anon} | _]) -> + true; +advertises_ec_ciphers([{ecdhe_psk, _,_,_} | _]) -> + true; +advertises_ec_ciphers([_| Rest]) -> + advertises_ec_ciphers(Rest). + +select_shared_curve([], _) -> + no_curve; +select_shared_curve([Curve | Rest], Curves) -> + case lists:member(Curve, Curves) of + true -> + {namedCurve, Curve}; + false -> + select_shared_curve(Rest, Curves) + end. + +sni(undefined) -> + undefined; +sni(disable) -> + undefined; +sni(Hostname) -> + #sni{hostname = Hostname}. + +renegotiation_info(_, client, _, false) -> + #renegotiation_info{renegotiated_connection = undefined}; +renegotiation_info(_RecordCB, server, ConnectionStates, false) -> + ConnectionState = ssl_record:current_connection_state(ConnectionStates, read), + case maps:get(secure_renegotiation, ConnectionState) of + true -> + #renegotiation_info{renegotiated_connection = ?byte(0)}; + false -> + #renegotiation_info{renegotiated_connection = undefined} + end; +renegotiation_info(_RecordCB, client, ConnectionStates, true) -> + ConnectionState = ssl_record:current_connection_state(ConnectionStates, read), + case maps:get(secure_renegotiation, ConnectionState) of + true -> + Data = maps:get(client_verify_data, ConnectionState), + #renegotiation_info{renegotiated_connection = Data}; + false -> + #renegotiation_info{renegotiated_connection = undefined} + end; + +renegotiation_info(_RecordCB, server, ConnectionStates, true) -> + ConnectionState = ssl_record:current_connection_state(ConnectionStates, read), + case maps:get(secure_renegotiation, ConnectionState) of + true -> + CData = maps:get(client_verify_data, ConnectionState), + SData = maps:get(server_verify_data, ConnectionState), + #renegotiation_info{renegotiated_connection = <<CData/binary, SData/binary>>}; + false -> + #renegotiation_info{renegotiated_connection = undefined} + end. + +handle_renegotiation_info(_RecordCB, _, #renegotiation_info{renegotiated_connection = ?byte(0)}, + ConnectionStates, false, _, _) -> + {ok, ssl_record:set_renegotiation_flag(true, ConnectionStates)}; + +handle_renegotiation_info(_RecordCB, server, undefined, ConnectionStates, _, _, CipherSuites) -> + case is_member(?TLS_EMPTY_RENEGOTIATION_INFO_SCSV, CipherSuites) of + true -> + {ok, ssl_record:set_renegotiation_flag(true, ConnectionStates)}; + false -> + {ok, ssl_record:set_renegotiation_flag(false, ConnectionStates)} + end; + +handle_renegotiation_info(_RecordCB, _, undefined, ConnectionStates, false, _, _) -> + {ok, ssl_record:set_renegotiation_flag(false, ConnectionStates)}; + +handle_renegotiation_info(_RecordCB, client, #renegotiation_info{renegotiated_connection = ClientServerVerify}, + ConnectionStates, true, _, _) -> + ConnectionState = ssl_record:current_connection_state(ConnectionStates, read), + CData = maps:get(client_verify_data, ConnectionState), + SData = maps:get(server_verify_data, ConnectionState), + case <<CData/binary, SData/binary>> == ClientServerVerify of + true -> + {ok, ConnectionStates}; + false -> + ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, client_renegotiation) + end; +handle_renegotiation_info(_RecordCB, server, #renegotiation_info{renegotiated_connection = ClientVerify}, + ConnectionStates, true, _, CipherSuites) -> + + case is_member(?TLS_EMPTY_RENEGOTIATION_INFO_SCSV, CipherSuites) of + true -> + ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, {server_renegotiation, empty_renegotiation_info_scsv}); + false -> + ConnectionState = ssl_record:current_connection_state(ConnectionStates, read), + Data = maps:get(client_verify_data, ConnectionState), + case Data == ClientVerify of + true -> + {ok, ConnectionStates}; + false -> + ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, server_renegotiation) + end + end; + +handle_renegotiation_info(RecordCB, client, undefined, ConnectionStates, true, SecureRenegotation, _) -> + handle_renegotiation_info(RecordCB, ConnectionStates, SecureRenegotation); + +handle_renegotiation_info(RecordCB, server, undefined, ConnectionStates, true, SecureRenegotation, CipherSuites) -> + case is_member(?TLS_EMPTY_RENEGOTIATION_INFO_SCSV, CipherSuites) of + true -> + ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, {server_renegotiation, empty_renegotiation_info_scsv}); + false -> + handle_renegotiation_info(RecordCB, ConnectionStates, SecureRenegotation) + end. + +handle_renegotiation_info(_RecordCB, ConnectionStates, SecureRenegotation) -> + ConnectionState = ssl_record:current_connection_state(ConnectionStates, read), + case {SecureRenegotation, maps:get(secure_renegotiation, ConnectionState)} of + {_, true} -> + ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, already_secure); + {true, false} -> + ?ALERT_REC(?FATAL, ?NO_RENEGOTIATION); + {false, false} -> + {ok, ConnectionStates} + end. diff --git a/lib/ssl/src/ssl_internal.hrl b/lib/ssl/src/ssl_internal.hrl index 24ac34653e..bbe1374fec 100644 --- a/lib/ssl/src/ssl_internal.hrl +++ b/lib/ssl/src/ssl_internal.hrl @@ -73,6 +73,7 @@ %% sslv3 is considered insecure due to lack of padding check (Poodle attack) %% Keep as interop with legacy software but do not support as default -define(ALL_AVAILABLE_VERSIONS, ['tlsv1.2', 'tlsv1.1', tlsv1, sslv3]). +-define(ALL_AVAILABLE_DATAGRAM_VERSIONS, ['dtlsv1.2', dtlsv1]). -define(ALL_SUPPORTED_VERSIONS, ['tlsv1.2', 'tlsv1.1', tlsv1]). -define(MIN_SUPPORTED_VERSIONS, ['tlsv1.1', tlsv1]). -define(ALL_DATAGRAM_SUPPORTED_VERSIONS, ['dtlsv1.2', dtlsv1]). @@ -95,7 +96,8 @@ certfile :: binary(), cert :: public_key:der_encoded() | secret_printout() | 'undefined', keyfile :: binary(), - key :: {'RSAPrivateKey' | 'DSAPrivateKey' | 'ECPrivateKey' | 'PrivateKeyInfo', public_key:der_encoded()} | secret_printout() | 'undefined', + key :: {'RSAPrivateKey' | 'DSAPrivateKey' | 'ECPrivateKey' | 'PrivateKeyInfo', + public_key:der_encoded()} | key_map() | secret_printout() | 'undefined', password :: string() | secret_printout() | 'undefined', cacerts :: [public_key:der_encoded()] | secret_printout() | 'undefined', cacertfile :: binary(), @@ -164,7 +166,15 @@ connection_cb }). - +-type key_map() :: #{algorithm := rsa | dss | ecdsa, + %% engine and key_id ought to + %% be :=, but putting it in + %% the spec gives dialyzer warning + %% of correct code! + engine => crypto:engine_ref(), + key_id => crypto:key_id(), + password => crypto:password() + }. -type state_name() :: hello | abbreviated | certify | cipher | connection. -type gen_fsm_state_return() :: {next_state, state_name(), term()} | {next_state, state_name(), term(), timeout()} | diff --git a/lib/ssl/src/ssl_record.erl b/lib/ssl/src/ssl_record.erl index 003ad4994b..dd6a3e8521 100644 --- a/lib/ssl/src/ssl_record.erl +++ b/lib/ssl/src/ssl_record.erl @@ -53,11 +53,11 @@ -type ssl_atom_version() :: tls_record:tls_atom_version(). -type connection_states() :: term(). %% Map -type connection_state() :: term(). %% Map + %%==================================================================== -%% Internal application API +%% Connection state handling %%==================================================================== - %%-------------------------------------------------------------------- -spec current_connection_state(connection_states(), read | write) -> connection_state(). @@ -267,6 +267,9 @@ set_pending_cipher_state(#{pending_read := Read, pending_read => Read#{cipher_state => ServerState}, pending_write => Write#{cipher_state => ClientState}}. +%%==================================================================== +%% Compression +%%==================================================================== uncompress(?NULL, Data, CS) -> {Data, CS}. @@ -282,6 +285,11 @@ compress(?NULL, Data, CS) -> compressions() -> [?byte(?NULL)]. + +%%==================================================================== +%% Payload encryption/decryption +%%==================================================================== + %%-------------------------------------------------------------------- -spec cipher(ssl_version(), iodata(), connection_state(), MacHash::binary()) -> {CipherFragment::binary(), connection_state()}. diff --git a/lib/ssl/src/tls_connection.erl b/lib/ssl/src/tls_connection.erl index 62452808ae..2872ca9fe5 100644 --- a/lib/ssl/src/tls_connection.erl +++ b/lib/ssl/src/tls_connection.erl @@ -45,10 +45,8 @@ %% Setup -export([start_fsm/8, start_link/7, init/1]). --export([encode_data/3, encode_alert/3]). - %% State transition handling --export([next_record/1, next_event/3, next_event/4]). +-export([next_record/1, next_event/3, next_event/4, handle_common_event/4]). %% Handshake handling -export([renegotiate/2, send_handshake/2, @@ -56,11 +54,11 @@ reinit_handshake_data/1, select_sni_extension/1, empty_connection_state/2]). %% Alert and close handling --export([send_alert/2, close/5, protocol_name/0]). +-export([encode_alert/3, send_alert/2, close/5, protocol_name/0]). %% Data handling --export([passive_receive/2, next_record_if_active/1, handle_common_event/4, send/3, - socket/5, setopts/3, getopts/3]). +-export([encode_data/3, passive_receive/2, next_record_if_active/1, send/3, + socket/5, setopts/3, getopts/3]). %% gen_statem state functions -export([init/3, error/3, downgrade/3, %% Initiation and take down states @@ -72,6 +70,9 @@ %%==================================================================== %% Internal application API %%==================================================================== +%%==================================================================== +%% Setup +%%==================================================================== start_fsm(Role, Host, Port, Socket, {#ssl_options{erl_dist = false},_, Tracker} = Opts, User, {CbModule, _,_, _} = CbInfo, Timeout) -> @@ -100,6 +101,165 @@ start_fsm(Role, Host, Port, Socket, {#ssl_options{erl_dist = true},_, Tracker} = Error end. +%%-------------------------------------------------------------------- +-spec start_link(atom(), host(), inet:port_number(), port(), list(), pid(), tuple()) -> + {ok, pid()} | ignore | {error, reason()}. +%% +%% Description: Creates a gen_statem process which calls Module:init/1 to +%% initialize. +%%-------------------------------------------------------------------- +start_link(Role, Host, Port, Socket, Options, User, CbInfo) -> + {ok, proc_lib:spawn_link(?MODULE, init, [[Role, Host, Port, Socket, Options, User, CbInfo]])}. + +init([Role, Host, Port, Socket, Options, User, CbInfo]) -> + process_flag(trap_exit, true), + State0 = initial_state(Role, Host, Port, Socket, Options, User, CbInfo), + try + State = ssl_connection:ssl_config(State0#state.ssl_options, Role, State0), + gen_statem:enter_loop(?MODULE, [], init, State) + catch throw:Error -> + gen_statem:enter_loop(?MODULE, [], error, {Error, State0}) + end. +%%==================================================================== +%% State transition handling +%%==================================================================== +next_record(#state{unprocessed_handshake_events = N} = State) when N > 0 -> + {no_record, State#state{unprocessed_handshake_events = N-1}}; + +next_record(#state{protocol_buffers = + #protocol_buffers{tls_packets = [], tls_cipher_texts = [CT | Rest]} + = Buffers, + connection_states = ConnStates0, + ssl_options = #ssl_options{padding_check = Check}} = State) -> + case tls_record:decode_cipher_text(CT, ConnStates0, Check) of + {Plain, ConnStates} -> + {Plain, State#state{protocol_buffers = + Buffers#protocol_buffers{tls_cipher_texts = Rest}, + connection_states = ConnStates}}; + #alert{} = Alert -> + {Alert, State} + end; +next_record(#state{protocol_buffers = #protocol_buffers{tls_packets = [], tls_cipher_texts = []}, + socket = Socket, + close_tag = CloseTag, + transport_cb = Transport} = State) -> + case tls_socket:setopts(Transport, Socket, [{active,once}]) of + ok -> + {no_record, State}; + _ -> + self() ! {CloseTag, Socket}, + {no_record, State} + end; +next_record(State) -> + {no_record, State}. + +next_event(StateName, Record, State) -> + next_event(StateName, Record, State, []). + +next_event(connection = StateName, no_record, State0, Actions) -> + case next_record_if_active(State0) of + {no_record, State} -> + ssl_connection:hibernate_after(StateName, State, Actions); + {#ssl_tls{} = Record, State} -> + {next_state, StateName, State, [{next_event, internal, {protocol_record, Record}} | Actions]}; + {#alert{} = Alert, State} -> + {next_state, StateName, State, [{next_event, internal, Alert} | Actions]} + end; +next_event(StateName, Record, State, Actions) -> + case Record of + no_record -> + {next_state, StateName, State, Actions}; + #ssl_tls{} = Record -> + {next_state, StateName, State, [{next_event, internal, {protocol_record, Record}} | Actions]}; + #alert{} = Alert -> + {next_state, StateName, State, [{next_event, internal, Alert} | Actions]} + end. + +handle_common_event(internal, #alert{} = Alert, StateName, + #state{negotiated_version = Version} = State) -> + ssl_connection:handle_own_alert(Alert, Version, StateName, State); +%%% TLS record protocol level handshake messages +handle_common_event(internal, #ssl_tls{type = ?HANDSHAKE, fragment = Data}, + StateName, #state{protocol_buffers = + #protocol_buffers{tls_handshake_buffer = Buf0} = Buffers, + negotiated_version = Version, + ssl_options = Options} = State0) -> + try + {Packets, Buf} = tls_handshake:get_tls_handshake(Version,Data,Buf0, Options), + State1 = + State0#state{protocol_buffers = + Buffers#protocol_buffers{tls_handshake_buffer = Buf}}, + case Packets of + [] -> + assert_buffer_sanity(Buf, Options), + {Record, State} = next_record(State1), + next_event(StateName, Record, State); + _ -> + Events = tls_handshake_events(Packets), + case StateName of + connection -> + ssl_connection:hibernate_after(StateName, State1, Events); + _ -> + {next_state, StateName, + State1#state{unprocessed_handshake_events = unprocessed_events(Events)}, Events} + end + end + catch throw:#alert{} = Alert -> + ssl_connection:handle_own_alert(Alert, Version, StateName, State0) + end; +%%% TLS record protocol level application data messages +handle_common_event(internal, #ssl_tls{type = ?APPLICATION_DATA, fragment = Data}, StateName, State) -> + {next_state, StateName, State, [{next_event, internal, {application_data, Data}}]}; +%%% TLS record protocol level change cipher messages +handle_common_event(internal, #ssl_tls{type = ?CHANGE_CIPHER_SPEC, fragment = Data}, StateName, State) -> + {next_state, StateName, State, [{next_event, internal, #change_cipher_spec{type = Data}}]}; +%%% TLS record protocol level Alert messages +handle_common_event(internal, #ssl_tls{type = ?ALERT, fragment = EncAlerts}, StateName, + #state{negotiated_version = Version} = State) -> + try decode_alerts(EncAlerts) of + Alerts = [_|_] -> + handle_alerts(Alerts, {next_state, StateName, State}); + [] -> + ssl_connection:handle_own_alert(?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, empty_alert), + Version, StateName, State); + #alert{} = Alert -> + ssl_connection:handle_own_alert(Alert, Version, StateName, State) + catch + _:_ -> + ssl_connection:handle_own_alert(?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, alert_decode_error), + Version, StateName, State) + + end; +%% Ignore unknown TLS record level protocol messages +handle_common_event(internal, #ssl_tls{type = _Unknown}, StateName, State) -> + {next_state, StateName, State}. +%%==================================================================== +%% Handshake handling +%%==================================================================== +renegotiate(#state{role = client} = State, Actions) -> + %% Handle same way as if server requested + %% the renegotiation + Hs0 = ssl_handshake:init_handshake_history(), + {next_state, connection, State#state{tls_handshake_history = Hs0}, + [{next_event, internal, #hello_request{}} | Actions]}; + +renegotiate(#state{role = server, + socket = Socket, + transport_cb = Transport, + negotiated_version = Version, + connection_states = ConnectionStates0} = State0, Actions) -> + HelloRequest = ssl_handshake:hello_request(), + Frag = tls_handshake:encode_handshake(HelloRequest, Version), + Hs0 = ssl_handshake:init_handshake_history(), + {BinMsg, ConnectionStates} = + tls_record:encode_handshake(Frag, Version, ConnectionStates0), + send(Transport, Socket, BinMsg), + State1 = State0#state{connection_states = + ConnectionStates, + tls_handshake_history = Hs0}, + {Record, State} = next_record(State1), + next_event(hello, Record, State, Actions). + send_handshake(Handshake, State) -> send_handshake_flight(queue_handshake(Handshake, State)). @@ -128,15 +288,6 @@ queue_change_cipher(Msg, #state{negotiated_version = Version, State0#state{connection_states = ConnectionStates, flight_buffer = Flight0 ++ [BinChangeCipher]}. -send_alert(Alert, #state{negotiated_version = Version, - socket = Socket, - transport_cb = Transport, - connection_states = ConnectionStates0} = State0) -> - {BinMsg, ConnectionStates} = - encode_alert(Alert, Version, ConnectionStates0), - send(Transport, Socket, BinMsg), - State0#state{connection_states = ConnectionStates}. - reinit_handshake_data(State) -> %% premaster_secret, public_key_info and tls_handshake_info %% are only needed during the handshake phase. @@ -155,8 +306,17 @@ select_sni_extension(_) -> empty_connection_state(ConnectionEnd, BeastMitigation) -> ssl_record:empty_connection_state(ConnectionEnd, BeastMitigation). -encode_data(Data, Version, ConnectionStates0)-> - tls_record:encode_data(Data, Version, ConnectionStates0). +%%==================================================================== +%% Alert and close handling +%%==================================================================== +send_alert(Alert, #state{negotiated_version = Version, + socket = Socket, + transport_cb = Transport, + connection_states = ConnectionStates0} = State0) -> + {BinMsg, ConnectionStates} = + encode_alert(Alert, Version, ConnectionStates0), + send(Transport, Socket, BinMsg), + State0#state{connection_states = ConnectionStates}. %%-------------------------------------------------------------------- -spec encode_alert(#alert{}, ssl_record:ssl_version(), ssl_record:connection_states()) -> @@ -166,42 +326,66 @@ encode_data(Data, Version, ConnectionStates0)-> %%-------------------------------------------------------------------- encode_alert(#alert{} = Alert, Version, ConnectionStates) -> tls_record:encode_alert_record(Alert, Version, ConnectionStates). - +%% User closes or recursive call! +close({close, Timeout}, Socket, Transport = gen_tcp, _,_) -> + tls_socket:setopts(Transport, Socket, [{active, false}]), + Transport:shutdown(Socket, write), + _ = Transport:recv(Socket, 0, Timeout), + ok; +%% Peer closed socket +close({shutdown, transport_closed}, Socket, Transport = gen_tcp, ConnectionStates, Check) -> + close({close, 0}, Socket, Transport, ConnectionStates, Check); +%% We generate fatal alert +close({shutdown, own_alert}, Socket, Transport = gen_tcp, ConnectionStates, Check) -> + %% Standard trick to try to make sure all + %% data sent to the tcp port is really delivered to the + %% peer application before tcp port is closed so that the peer will + %% get the correct TLS alert message and not only a transport close. + %% Will return when other side has closed or after timout millisec + %% e.g. we do not want to hang if something goes wrong + %% with the network but we want to maximise the odds that + %% peer application gets all data sent on the tcp connection. + close({close, ?DEFAULT_TIMEOUT}, Socket, Transport, ConnectionStates, Check); +close(downgrade, _,_,_,_) -> + ok; +%% Other +close(_, Socket, Transport, _,_) -> + Transport:close(Socket). protocol_name() -> "TLS". -%%==================================================================== -%% tls_connection_sup API -%%==================================================================== -%%-------------------------------------------------------------------- --spec start_link(atom(), host(), inet:port_number(), port(), list(), pid(), tuple()) -> - {ok, pid()} | ignore | {error, reason()}. -%% -%% Description: Creates a gen_fsm process which calls Module:init/1 to -%% initialize. To ensure a synchronized start-up procedure, this function -%% does not return until Module:init/1 has returned. -%%-------------------------------------------------------------------- -start_link(Role, Host, Port, Socket, Options, User, CbInfo) -> - {ok, proc_lib:spawn_link(?MODULE, init, [[Role, Host, Port, Socket, Options, User, CbInfo]])}. +%%==================================================================== +%% Data handling +%%==================================================================== +encode_data(Data, Version, ConnectionStates0)-> + tls_record:encode_data(Data, Version, ConnectionStates0). -init([Role, Host, Port, Socket, Options, User, CbInfo]) -> - process_flag(trap_exit, true), - State0 = initial_state(Role, Host, Port, Socket, Options, User, CbInfo), - try - State = ssl_connection:ssl_config(State0#state.ssl_options, Role, State0), - gen_statem:enter_loop(?MODULE, [], init, State) - catch throw:Error -> - gen_statem:enter_loop(?MODULE, [], error, {Error, State0}) +passive_receive(State0 = #state{user_data_buffer = Buffer}, StateName) -> + case Buffer of + <<>> -> + {Record, State} = next_record(State0), + next_event(StateName, Record, State); + _ -> + {Record, State} = ssl_connection:read_application_data(<<>>, State0), + next_event(StateName, Record, State) end. -callback_mode() -> - state_functions. +next_record_if_active(State = + #state{socket_options = + #socket_options{active = false}}) -> + {no_record ,State}; +next_record_if_active(State) -> + next_record(State). + +send(Transport, Socket, Data) -> + tls_socket:send(Transport, Socket, Data). socket(Pid, Transport, Socket, Connection, Tracker) -> tls_socket:socket(Pid, Transport, Socket, Connection, Tracker). setopts(Transport, Socket, Other) -> tls_socket:setopts(Transport, Socket, Other). + getopts(Transport, Socket, Tag) -> tls_socket:getopts(Transport, Socket, Tag). @@ -244,7 +428,7 @@ init({call, From}, {start, Timeout}, {Record, State} = next_record(State1), next_event(hello, Record, State); init(Type, Event, State) -> - gen_handshake(ssl_connection, ?FUNCTION_NAME, Type, Event, State). + gen_handshake(?FUNCTION_NAME, Type, Event, State). %%-------------------------------------------------------------------- -spec error(gen_statem:event_type(), @@ -253,9 +437,15 @@ init(Type, Event, State) -> %%-------------------------------------------------------------------- error({call, From}, {start, _Timeout}, {Error, State}) -> - {stop_and_reply, normal, {reply, From, {error, Error}}, State}; -error({call, From}, Msg, State) -> - handle_call(Msg, From, ?FUNCTION_NAME, State); + ssl_connection:stop_and_reply( + normal, {reply, From, {error, Error}}, State); +error({call, From}, {start, _Timeout}, + #state{protocol_specific = #{error := Error}} = State) -> + ssl_connection:stop_and_reply( + normal, {reply, From, {error, Error}}, State); +error({call, _} = Call, Msg, {Error, #state{protocol_specific = Map} = State}) -> + gen_handshake(?FUNCTION_NAME, Call, Msg, + State#state{protocol_specific = Map#{error => Error}}); error(_, _, _) -> {keep_state_and_data, [postpone]}. @@ -285,13 +475,13 @@ hello(internal, #client_hello{client_version = ClientVersion} = Hello, undefined -> CurrentProtocol; _ -> Protocol0 end, - - gen_handshake(ssl_connection, hello, internal, {common_client_hello, Type, ServerHelloExt}, - State#state{connection_states = ConnectionStates, - negotiated_version = Version, - hashsign_algorithm = HashSign, - session = Session, - negotiated_protocol = Protocol}) + gen_handshake(?FUNCTION_NAME, internal, {common_client_hello, Type, ServerHelloExt}, + State#state{connection_states = ConnectionStates, + negotiated_version = Version, + hashsign_algorithm = HashSign, + client_hello_version = ClientVersion, + session = Session, + negotiated_protocol = Protocol}) end; hello(internal, #server_hello{} = Hello, #state{connection_states = ConnectionStates0, @@ -309,7 +499,7 @@ hello(internal, #server_hello{} = Hello, hello(info, Event, State) -> gen_info(Event, ?FUNCTION_NAME, State); hello(Type, Event, State) -> - gen_handshake(ssl_connection, ?FUNCTION_NAME, Type, Event, State). + gen_handshake(?FUNCTION_NAME, Type, Event, State). %%-------------------------------------------------------------------- -spec abbreviated(gen_statem:event_type(), term(), #state{}) -> @@ -318,7 +508,7 @@ hello(Type, Event, State) -> abbreviated(info, Event, State) -> gen_info(Event, ?FUNCTION_NAME, State); abbreviated(Type, Event, State) -> - gen_handshake(ssl_connection, ?FUNCTION_NAME, Type, Event, State). + gen_handshake(?FUNCTION_NAME, Type, Event, State). %%-------------------------------------------------------------------- -spec certify(gen_statem:event_type(), term(), #state{}) -> @@ -327,7 +517,7 @@ abbreviated(Type, Event, State) -> certify(info, Event, State) -> gen_info(Event, ?FUNCTION_NAME, State); certify(Type, Event, State) -> - gen_handshake(ssl_connection, ?FUNCTION_NAME, Type, Event, State). + gen_handshake(?FUNCTION_NAME, Type, Event, State). %%-------------------------------------------------------------------- -spec cipher(gen_statem:event_type(), term(), #state{}) -> @@ -336,7 +526,7 @@ certify(Type, Event, State) -> cipher(info, Event, State) -> gen_info(Event, ?FUNCTION_NAME, State); cipher(Type, Event, State) -> - gen_handshake(ssl_connection, ?FUNCTION_NAME, Type, Event, State). + gen_handshake(?FUNCTION_NAME, Type, Event, State). %%-------------------------------------------------------------------- -spec connection(gen_statem:event_type(), @@ -394,156 +584,24 @@ death_row(Type, Event, State) -> downgrade(Type, Event, State) -> ssl_connection:?FUNCTION_NAME(Type, Event, State, ?MODULE). -%%-------------------------------------------------------------------- -%% Event handling functions called by state functions to handle -%% common or unexpected events for the state. -%%-------------------------------------------------------------------- -handle_call(Event, From, StateName, State) -> - ssl_connection:handle_call(Event, From, StateName, State, ?MODULE). - -%% raw data from socket, unpack records -handle_info({Protocol, _, Data}, StateName, - #state{data_tag = Protocol} = State0) -> - case next_tls_record(Data, State0) of - {Record, State} -> - next_event(StateName, Record, State); - #alert{} = Alert -> - ssl_connection:handle_normal_shutdown(Alert, StateName, State0), - {stop, {shutdown, own_alert}} - end; -handle_info({CloseTag, Socket}, StateName, - #state{socket = Socket, close_tag = CloseTag, - socket_options = #socket_options{active = Active}, - protocol_buffers = #protocol_buffers{tls_cipher_texts = CTs}, - negotiated_version = Version} = State) -> - - %% Note that as of TLS 1.1, - %% failure to properly close a connection no longer requires that a - %% session not be resumed. This is a change from TLS 1.0 to conform - %% with widespread implementation practice. - - case (Active == false) andalso (CTs =/= []) of - false -> - case Version of - {1, N} when N >= 1 -> - ok; - _ -> - %% As invalidate_sessions here causes performance issues, - %% we will conform to the widespread implementation - %% practice and go aginst the spec - %%invalidate_session(Role, Host, Port, Session) - ok - end, - - ssl_connection:handle_normal_shutdown(?ALERT_REC(?FATAL, ?CLOSE_NOTIFY), StateName, State), - {stop, {shutdown, transport_closed}}; - true -> - %% Fixes non-delivery of final TLS record in {active, once}. - %% Basically allows the application the opportunity to set {active, once} again - %% and then receive the final message. - next_event(StateName, no_record, State) - end; -handle_info(Msg, StateName, State) -> - ssl_connection:StateName(info, Msg, State, ?MODULE). - -handle_common_event(internal, #alert{} = Alert, StateName, - #state{negotiated_version = Version} = State) -> - ssl_connection:handle_own_alert(Alert, Version, StateName, State); - -%%% TLS record protocol level handshake messages -handle_common_event(internal, #ssl_tls{type = ?HANDSHAKE, fragment = Data}, - StateName, #state{protocol_buffers = - #protocol_buffers{tls_handshake_buffer = Buf0} = Buffers, - negotiated_version = Version, - ssl_options = Options} = State0) -> - try - {Packets, Buf} = tls_handshake:get_tls_handshake(Version,Data,Buf0, Options), - State1 = - State0#state{protocol_buffers = - Buffers#protocol_buffers{tls_handshake_buffer = Buf}}, - case Packets of - [] -> - assert_buffer_sanity(Buf, Options), - {Record, State} = next_record(State1), - next_event(StateName, Record, State); - _ -> - Events = tls_handshake_events(Packets), - case StateName of - connection -> - ssl_connection:hibernate_after(StateName, State1, Events); - _ -> - {next_state, StateName, - State1#state{unprocessed_handshake_events = unprocessed_events(Events)}, Events} - end - end - catch throw:#alert{} = Alert -> - ssl_connection:handle_own_alert(Alert, Version, StateName, State0) - end; -%%% TLS record protocol level application data messages -handle_common_event(internal, #ssl_tls{type = ?APPLICATION_DATA, fragment = Data}, StateName, State) -> - {next_state, StateName, State, [{next_event, internal, {application_data, Data}}]}; -%%% TLS record protocol level change cipher messages -handle_common_event(internal, #ssl_tls{type = ?CHANGE_CIPHER_SPEC, fragment = Data}, StateName, State) -> - {next_state, StateName, State, [{next_event, internal, #change_cipher_spec{type = Data}}]}; -%%% TLS record protocol level Alert messages -handle_common_event(internal, #ssl_tls{type = ?ALERT, fragment = EncAlerts}, StateName, - #state{negotiated_version = Version} = State) -> - try decode_alerts(EncAlerts) of - Alerts = [_|_] -> - handle_alerts(Alerts, {next_state, StateName, State}); - [] -> - ssl_connection:handle_own_alert(?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, empty_alert), - Version, StateName, State); - #alert{} = Alert -> - ssl_connection:handle_own_alert(Alert, Version, StateName, State) - catch - _:_ -> - ssl_connection:handle_own_alert(?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, alert_decode_error), - Version, StateName, State) - - end; -%% Ignore unknown TLS record level protocol messages -handle_common_event(internal, #ssl_tls{type = _Unknown}, StateName, State) -> - {next_state, StateName, State}. - -send(Transport, Socket, Data) -> - tls_socket:send(Transport, Socket, Data). - -%%-------------------------------------------------------------------- +%-------------------------------------------------------------------- %% gen_statem callbacks %%-------------------------------------------------------------------- +callback_mode() -> + state_functions. + terminate(Reason, StateName, State) -> catch ssl_connection:terminate(Reason, StateName, State). format_status(Type, Data) -> ssl_connection:format_status(Type, Data). -%%-------------------------------------------------------------------- -%% code_change(OldVsn, StateName, State, Extra) -> {ok, StateName, NewState} -%% Description: Convert process state when code is changed -%%-------------------------------------------------------------------- -code_change(_OldVsn, StateName, State0, {Direction, From, To}) -> - State = convert_state(State0, Direction, From, To), - {ok, StateName, State}; code_change(_OldVsn, StateName, State, _) -> {ok, StateName, State}. %%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- -encode_handshake(Handshake, Version, ConnectionStates0, Hist0, V2HComp) -> - Frag = tls_handshake:encode_handshake(Handshake, Version), - Hist = ssl_handshake:update_handshake_history(Hist0, Frag, V2HComp), - {Encoded, ConnectionStates} = - tls_record:encode_handshake(Frag, Version, ConnectionStates0), - {Encoded, ConnectionStates, Hist}. - -encode_change_cipher(#change_cipher_spec{}, Version, ConnectionStates) -> - tls_record:encode_change_cipher_spec(Version, ConnectionStates). - -decode_alerts(Bin) -> - ssl_alert:decode(Bin). - initial_state(Role, Host, Port, Socket, {SSLOptions, SocketOptions, Tracker}, User, {CbModule, DataTag, CloseTag, ErrorTag}) -> #ssl_options{beast_mitigation = BeastMitigation} = SSLOptions, @@ -582,170 +640,109 @@ initial_state(Role, Host, Port, Socket, {SSLOptions, SocketOptions, Tracker}, Us flight_buffer = [] }. -next_tls_record(Data, #state{protocol_buffers = #protocol_buffers{tls_record_buffer = Buf0, - tls_cipher_texts = CT0} = Buffers} = State0) -> - case tls_record:get_tls_records(Data, Buf0) of +next_tls_record(Data, StateName, #state{protocol_buffers = + #protocol_buffers{tls_record_buffer = Buf0, + tls_cipher_texts = CT0} = Buffers} + = State0) -> + case tls_record:get_tls_records(Data, + acceptable_record_versions(StateName, State0), + Buf0) of {Records, Buf1} -> CT1 = CT0 ++ Records, next_record(State0#state{protocol_buffers = Buffers#protocol_buffers{tls_record_buffer = Buf1, tls_cipher_texts = CT1}}); #alert{} = Alert -> - Alert + handle_record_alert(Alert, State0) end. -next_record(#state{unprocessed_handshake_events = N} = State) when N > 0 -> - {no_record, State#state{unprocessed_handshake_events = N-1}}; - -next_record(#state{protocol_buffers = - #protocol_buffers{tls_packets = [], tls_cipher_texts = [CT | Rest]} - = Buffers, - connection_states = ConnStates0, - ssl_options = #ssl_options{padding_check = Check}} = State) -> - case tls_record:decode_cipher_text(CT, ConnStates0, Check) of - {Plain, ConnStates} -> - {Plain, State#state{protocol_buffers = - Buffers#protocol_buffers{tls_cipher_texts = Rest}, - connection_states = ConnStates}}; - #alert{} = Alert -> - {Alert, State} - end; -next_record(#state{protocol_buffers = #protocol_buffers{tls_packets = [], tls_cipher_texts = []}, - socket = Socket, - transport_cb = Transport} = State) -> - case tls_socket:setopts(Transport, Socket, [{active,once}]) of - ok -> - {no_record, State}; - _ -> - {socket_closed, State} - end; -next_record(State) -> - {no_record, State}. -next_record_if_active(State = - #state{socket_options = - #socket_options{active = false}}) -> - {no_record ,State}; - -next_record_if_active(State) -> - next_record(State). - -passive_receive(State0 = #state{user_data_buffer = Buffer}, StateName) -> - case Buffer of - <<>> -> - {Record, State} = next_record(State0), - next_event(StateName, Record, State); - _ -> - {Record, State} = ssl_connection:read_application_data(<<>>, State0), - next_event(StateName, Record, State) - end. - -next_event(StateName, Record, State) -> - next_event(StateName, Record, State, []). - -next_event(StateName, socket_closed, State, _) -> - ssl_connection:handle_normal_shutdown(?ALERT_REC(?FATAL, ?CLOSE_NOTIFY), StateName, State), - {stop, {shutdown, transport_closed}, State}; -next_event(connection = StateName, no_record, State0, Actions) -> - case next_record_if_active(State0) of - {no_record, State} -> - ssl_connection:hibernate_after(StateName, State, Actions); - {socket_closed, State} -> - next_event(StateName, socket_closed, State, Actions); - {#ssl_tls{} = Record, State} -> - {next_state, StateName, State, [{next_event, internal, {protocol_record, Record}} | Actions]}; - {#alert{} = Alert, State} -> - {next_state, StateName, State, [{next_event, internal, Alert} | Actions]} - end; -next_event(StateName, Record, State, Actions) -> - case Record of - no_record -> - {next_state, StateName, State, Actions}; - #ssl_tls{} = Record -> - {next_state, StateName, State, [{next_event, internal, {protocol_record, Record}} | Actions]}; - #alert{} = Alert -> - {next_state, StateName, State, [{next_event, internal, Alert} | Actions]} - end. +acceptable_record_versions(hello, #state{ssl_options = #ssl_options{v2_hello_compatible = true}}) -> + [tls_record:protocol_version(Vsn) || Vsn <- ?ALL_AVAILABLE_VERSIONS ++ ['sslv2']]; +acceptable_record_versions(hello, _) -> + [tls_record:protocol_version(Vsn) || Vsn <- ?ALL_AVAILABLE_VERSIONS]; +acceptable_record_versions(_, #state{negotiated_version = Version}) -> + [Version]. +handle_record_alert(#alert{description = ?BAD_RECORD_MAC}, + #state{ssl_options = #ssl_options{v2_hello_compatible = true}}) -> + ?ALERT_REC(?FATAL, ?PROTOCOL_VERSION); +handle_record_alert(Alert, _) -> + Alert. tls_handshake_events(Packets) -> lists:map(fun(Packet) -> {next_event, internal, {handshake, Packet}} end, Packets). +%% raw data from socket, upack records +handle_info({Protocol, _, Data}, StateName, + #state{data_tag = Protocol} = State0) -> + case next_tls_record(Data, StateName, State0) of + {Record, State} -> + next_event(StateName, Record, State); + #alert{} = Alert -> + ssl_connection:handle_normal_shutdown(Alert, StateName, State0), + ssl_connection:stop({shutdown, own_alert}, State0) + end; +handle_info({CloseTag, Socket}, StateName, + #state{socket = Socket, close_tag = CloseTag, + socket_options = #socket_options{active = Active}, + protocol_buffers = #protocol_buffers{tls_cipher_texts = CTs}, + negotiated_version = Version} = State) -> -renegotiate(#state{role = client} = State, Actions) -> - %% Handle same way as if server requested - %% the renegotiation - Hs0 = ssl_handshake:init_handshake_history(), - {next_state, connection, State#state{tls_handshake_history = Hs0}, - [{next_event, internal, #hello_request{}} | Actions]}; + %% Note that as of TLS 1.1, + %% failure to properly close a connection no longer requires that a + %% session not be resumed. This is a change from TLS 1.0 to conform + %% with widespread implementation practice. -renegotiate(#state{role = server, - socket = Socket, - transport_cb = Transport, - negotiated_version = Version, - connection_states = ConnectionStates0} = State0, Actions) -> - HelloRequest = ssl_handshake:hello_request(), - Frag = tls_handshake:encode_handshake(HelloRequest, Version), - Hs0 = ssl_handshake:init_handshake_history(), - {BinMsg, ConnectionStates} = - tls_record:encode_handshake(Frag, Version, ConnectionStates0), - send(Transport, Socket, BinMsg), - State1 = State0#state{connection_states = - ConnectionStates, - tls_handshake_history = Hs0}, - {Record, State} = next_record(State1), - next_event(hello, Record, State, Actions). + case (Active == false) andalso (CTs =/= []) of + false -> + case Version of + {1, N} when N >= 1 -> + ok; + _ -> + %% As invalidate_sessions here causes performance issues, + %% we will conform to the widespread implementation + %% practice and go aginst the spec + %%invalidate_session(Role, Host, Port, Session) + ok + end, + + ssl_connection:handle_normal_shutdown(?ALERT_REC(?FATAL, ?CLOSE_NOTIFY), StateName, State), + ssl_connection:stop({shutdown, transport_closed}, State); + true -> + %% Fixes non-delivery of final TLS record in {active, once}. + %% Basically allows the application the opportunity to set {active, once} again + %% and then receive the final message. + next_event(StateName, no_record, State) + end; +handle_info(Msg, StateName, State) -> + ssl_connection:StateName(info, Msg, State, ?MODULE). handle_alerts([], Result) -> Result; -handle_alerts(_, {stop,_} = Stop) -> +handle_alerts(_, {stop, _, _} = Stop) -> Stop; handle_alerts([Alert | Alerts], {next_state, StateName, State}) -> handle_alerts(Alerts, ssl_connection:handle_alert(Alert, StateName, State)); handle_alerts([Alert | Alerts], {next_state, StateName, State, _Actions}) -> handle_alerts(Alerts, ssl_connection:handle_alert(Alert, StateName, State)). +encode_handshake(Handshake, Version, ConnectionStates0, Hist0, V2HComp) -> + Frag = tls_handshake:encode_handshake(Handshake, Version), + Hist = ssl_handshake:update_handshake_history(Hist0, Frag, V2HComp), + {Encoded, ConnectionStates} = + tls_record:encode_handshake(Frag, Version, ConnectionStates0), + {Encoded, ConnectionStates, Hist}. -%% User closes or recursive call! -close({close, Timeout}, Socket, Transport = gen_tcp, _,_) -> - tls_socket:setopts(Transport, Socket, [{active, false}]), - Transport:shutdown(Socket, write), - _ = Transport:recv(Socket, 0, Timeout), - ok; -%% Peer closed socket -close({shutdown, transport_closed}, Socket, Transport = gen_tcp, ConnectionStates, Check) -> - close({close, 0}, Socket, Transport, ConnectionStates, Check); -%% We generate fatal alert -close({shutdown, own_alert}, Socket, Transport = gen_tcp, ConnectionStates, Check) -> - %% Standard trick to try to make sure all - %% data sent to the tcp port is really delivered to the - %% peer application before tcp port is closed so that the peer will - %% get the correct TLS alert message and not only a transport close. - %% Will return when other side has closed or after timout millisec - %% e.g. we do not want to hang if something goes wrong - %% with the network but we want to maximise the odds that - %% peer application gets all data sent on the tcp connection. - close({close, ?DEFAULT_TIMEOUT}, Socket, Transport, ConnectionStates, Check); -close(downgrade, _,_,_,_) -> - ok; -%% Other -close(_, Socket, Transport, _,_) -> - Transport:close(Socket). - -convert_state(#state{ssl_options = Options} = State, up, "5.3.5", "5.3.6") -> - State#state{ssl_options = convert_options_partial_chain(Options, up)}; -convert_state(#state{ssl_options = Options} = State, down, "5.3.6", "5.3.5") -> - State#state{ssl_options = convert_options_partial_chain(Options, down)}. +encode_change_cipher(#change_cipher_spec{}, Version, ConnectionStates) -> + tls_record:encode_change_cipher_spec(Version, ConnectionStates). -convert_options_partial_chain(Options, up) -> - {Head, Tail} = lists:split(5, tuple_to_list(Options)), - list_to_tuple(Head ++ [{partial_chain, fun(_) -> unknown_ca end}] ++ Tail); -convert_options_partial_chain(Options, down) -> - list_to_tuple(proplists:delete(partial_chain, tuple_to_list(Options))). +decode_alerts(Bin) -> + ssl_alert:decode(Bin). -gen_handshake(GenConnection, StateName, Type, Event, +gen_handshake(StateName, Type, Event, #state{negotiated_version = Version} = State) -> - try GenConnection:StateName(Type, Event, State, ?MODULE) of + try ssl_connection:StateName(Type, Event, State, ?MODULE) of Result -> Result catch diff --git a/lib/ssl/src/tls_handshake.erl b/lib/ssl/src/tls_handshake.erl index b54540393a..8817418fb0 100644 --- a/lib/ssl/src/tls_handshake.erl +++ b/lib/ssl/src/tls_handshake.erl @@ -32,13 +32,19 @@ -include("ssl_cipher.hrl"). -include_lib("public_key/include/public_key.hrl"). --export([client_hello/8, hello/4, - get_tls_handshake/4, encode_handshake/2, decode_handshake/4]). +%% Handshake handling +-export([client_hello/8, hello/4]). + +%% Handshake encoding +-export([encode_handshake/2]). + +%% Handshake decodeing +-export([get_tls_handshake/4, decode_handshake/4]). -type tls_handshake() :: #client_hello{} | ssl_handshake:ssl_handshake(). %%==================================================================== -%% Internal application API +%% Handshake handling %%==================================================================== %%-------------------------------------------------------------------- -spec client_hello(host(), inet:port_number(), ssl_record:connection_states(), @@ -54,18 +60,14 @@ client_hello(Host, Port, ConnectionStates, } = SslOpts, Cache, CacheCb, Renegotiation, OwnCert) -> Version = tls_record:highest_protocol_version(Versions), - #{security_parameters := SecParams} = ssl_record:pending_connection_state(ConnectionStates, read), + #{security_parameters := SecParams} = + ssl_record:pending_connection_state(ConnectionStates, read), AvailableCipherSuites = ssl_handshake:available_suites(UserSuites, Version), Extensions = ssl_handshake:client_hello_extensions(Version, AvailableCipherSuites, - SslOpts, ConnectionStates, Renegotiation), - CipherSuites = - case Fallback of - true -> - [?TLS_FALLBACK_SCSV | ssl_handshake:cipher_suites(AvailableCipherSuites, Renegotiation)]; - false -> - ssl_handshake:cipher_suites(AvailableCipherSuites, Renegotiation) - end, + SslOpts, ConnectionStates, + Renegotiation), + CipherSuites = ssl_handshake:cipher_suites(AvailableCipherSuites, Renegotiation, Fallback), Id = ssl_session:client_id({Host, Port, SslOpts}, Cache, CacheCb, OwnCert), #client_hello{session_id = Id, client_version = Version, @@ -85,8 +87,8 @@ client_hello(Host, Port, ConnectionStates, ssl_record:connection_states(), alpn | npn, binary() | undefined}| {tls_record:tls_version(), {resumed | new, #session{}}, ssl_record:connection_states(), binary() | undefined, - #hello_extensions{}, {ssl_cipher:hash(), ssl_cipher:sign_algo()} | undefined} | - #alert{}. + #hello_extensions{}, {ssl_cipher:hash(), ssl_cipher:sign_algo()} | + undefined} | #alert{}. %% %% Description: Handles a received hello message %%-------------------------------------------------------------------- @@ -99,7 +101,8 @@ hello(#server_hello{server_version = Version, random = Random, case tls_record:is_acceptable_version(Version, SupportedVersions) of true -> handle_server_hello_extensions(Version, SessionId, Random, CipherSuite, - Compression, HelloExt, SslOpt, ConnectionStates0, Renegotiation); + Compression, HelloExt, SslOpt, + ConnectionStates0, Renegotiation); false -> ?ALERT_REC(?FATAL, ?PROTOCOL_VERSION) end; @@ -127,18 +130,29 @@ hello(#client_hello{client_version = ClientVersion, ?ALERT_REC(?FATAL, ?HANDSHAKE_FAILURE, malformed_handshake_data) end. + +%%-------------------------------------------------------------------- +%%% Handshake encodeing +%%-------------------------------------------------------------------- + %%-------------------------------------------------------------------- -spec encode_handshake(tls_handshake(), tls_record:tls_version()) -> iolist(). %% %% Description: Encode a handshake packet -%%--------------------------------------------------------------------x +%%-------------------------------------------------------------------- encode_handshake(Package, Version) -> {MsgType, Bin} = enc_handshake(Package, Version), Len = byte_size(Bin), [MsgType, ?uint24(Len), Bin]. + +%%-------------------------------------------------------------------- +%%% Handshake decodeing +%%-------------------------------------------------------------------- + %%-------------------------------------------------------------------- --spec get_tls_handshake(tls_record:tls_version(), binary(), binary() | iolist(), #ssl_options{}) -> +-spec get_tls_handshake(tls_record:tls_version(), binary(), binary() | iolist(), + #ssl_options{}) -> {[tls_handshake()], binary()}. %% %% Description: Given buffered and new data from ssl_record, collects @@ -153,37 +167,45 @@ get_tls_handshake(Version, Data, Buffer, Options) -> %%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- -handle_client_hello(Version, #client_hello{session_id = SugesstedId, - cipher_suites = CipherSuites, - compression_methods = Compressions, - random = Random, - extensions = #hello_extensions{elliptic_curves = Curves, - signature_algs = ClientHashSigns} = HelloExt}, +handle_client_hello(Version, + #client_hello{session_id = SugesstedId, + cipher_suites = CipherSuites, + compression_methods = Compressions, + random = Random, + extensions = + #hello_extensions{elliptic_curves = Curves, + signature_algs = ClientHashSigns} + = HelloExt}, #ssl_options{versions = Versions, signature_algs = SupportedHashSigns, eccs = SupportedECCs, honor_ecc_order = ECCOrder} = SslOpts, - {Port, Session0, Cache, CacheCb, ConnectionStates0, Cert, _}, Renegotiation) -> + {Port, Session0, Cache, CacheCb, ConnectionStates0, Cert, _}, + Renegotiation) -> case tls_record:is_acceptable_version(Version, Versions) of true -> AvailableHashSigns = ssl_handshake:available_signature_algs( ClientHashSigns, SupportedHashSigns, Cert, Version), ECCCurve = ssl_handshake:select_curve(Curves, SupportedECCs, ECCOrder), {Type, #session{cipher_suite = CipherSuite} = Session1} - = ssl_handshake:select_session(SugesstedId, CipherSuites, AvailableHashSigns, Compressions, - Port, Session0#session{ecc = ECCCurve}, Version, - SslOpts, Cache, CacheCb, Cert), + = ssl_handshake:select_session(SugesstedId, CipherSuites, + AvailableHashSigns, Compressions, + Port, Session0#session{ecc = ECCCurve}, + Version, SslOpts, Cache, CacheCb, Cert), case CipherSuite of no_suite -> ?ALERT_REC(?FATAL, ?INSUFFICIENT_SECURITY, no_suitable_ciphers); _ -> - {KeyExAlg,_,_,_} = ssl_cipher:suite_definition(CipherSuite), - case ssl_handshake:select_hashsign(ClientHashSigns, Cert, KeyExAlg, SupportedHashSigns, Version) of + #{key_exchange := KeyExAlg} = ssl_cipher:suite_definition(CipherSuite), + case ssl_handshake:select_hashsign(ClientHashSigns, Cert, KeyExAlg, + SupportedHashSigns, Version) of #alert{} = Alert -> Alert; HashSign -> - handle_client_hello_extensions(Version, Type, Random, CipherSuites, HelloExt, - SslOpts, Session1, ConnectionStates0, + handle_client_hello_extensions(Version, Type, Random, + CipherSuites, HelloExt, + SslOpts, Session1, + ConnectionStates0, Renegotiation, HashSign) end end; @@ -191,6 +213,59 @@ handle_client_hello(Version, #client_hello{session_id = SugesstedId, ?ALERT_REC(?FATAL, ?PROTOCOL_VERSION) end. +handle_client_hello_extensions(Version, Type, Random, CipherSuites, + HelloExt, SslOpts, Session0, ConnectionStates0, + Renegotiation, HashSign) -> + try ssl_handshake:handle_client_hello_extensions(tls_record, Random, CipherSuites, + HelloExt, Version, SslOpts, + Session0, ConnectionStates0, + Renegotiation) of + #alert{} = Alert -> + Alert; + {Session, ConnectionStates, Protocol, ServerHelloExt} -> + {Version, {Type, Session}, ConnectionStates, Protocol, + ServerHelloExt, HashSign} + catch throw:Alert -> + Alert + end. + + +handle_server_hello_extensions(Version, SessionId, Random, CipherSuite, + Compression, HelloExt, SslOpt, ConnectionStates0, Renegotiation) -> + case ssl_handshake:handle_server_hello_extensions(tls_record, Random, CipherSuite, + Compression, HelloExt, Version, + SslOpt, ConnectionStates0, + Renegotiation) of + #alert{} = Alert -> + Alert; + {ConnectionStates, ProtoExt, Protocol} -> + {Version, SessionId, ConnectionStates, ProtoExt, Protocol} + end. +%%-------------------------------------------------------------------- +enc_handshake(#hello_request{}, _Version) -> + {?HELLO_REQUEST, <<>>}; +enc_handshake(#client_hello{client_version = {Major, Minor}, + random = Random, + session_id = SessionID, + cipher_suites = CipherSuites, + compression_methods = CompMethods, + extensions = HelloExtensions}, _Version) -> + SIDLength = byte_size(SessionID), + BinCompMethods = list_to_binary(CompMethods), + CmLength = byte_size(BinCompMethods), + BinCipherSuites = list_to_binary(CipherSuites), + CsLength = byte_size(BinCipherSuites), + ExtensionsBin = ssl_handshake:encode_hello_extensions(HelloExtensions), + + {?CLIENT_HELLO, <<?BYTE(Major), ?BYTE(Minor), Random:32/binary, + ?BYTE(SIDLength), SessionID/binary, + ?UINT16(CsLength), BinCipherSuites/binary, + ?BYTE(CmLength), BinCompMethods/binary, ExtensionsBin/binary>>}; + +enc_handshake(HandshakeMsg, Version) -> + ssl_handshake:encode_handshake(HandshakeMsg, Version). + +%%-------------------------------------------------------------------- get_tls_handshake_aux(Version, <<?BYTE(Type), ?UINT24(Length), Body:Length/binary,Rest/binary>>, #ssl_options{v2_hello_compatible = V2Hello} = Opts, Acc) -> @@ -219,11 +294,12 @@ decode_handshake(_Version, ?CLIENT_HELLO, Bin, true) -> decode_handshake(_Version, ?CLIENT_HELLO, Bin, false) -> decode_hello(Bin); -decode_handshake(_Version, ?CLIENT_HELLO, <<?BYTE(Major), ?BYTE(Minor), Random:32/binary, - ?BYTE(SID_length), Session_ID:SID_length/binary, - ?UINT16(Cs_length), CipherSuites:Cs_length/binary, - ?BYTE(Cm_length), Comp_methods:Cm_length/binary, - Extensions/binary>>, _) -> +decode_handshake(_Version, ?CLIENT_HELLO, + <<?BYTE(Major), ?BYTE(Minor), Random:32/binary, + ?BYTE(SID_length), Session_ID:SID_length/binary, + ?UINT16(Cs_length), CipherSuites:Cs_length/binary, + ?BYTE(Cm_length), Comp_methods:Cm_length/binary, + Extensions/binary>>, _) -> DecodedExtensions = ssl_handshake:decode_hello_extensions({client, Extensions}), @@ -268,53 +344,3 @@ decode_v2_hello(<<?BYTE(Major), ?BYTE(Minor), compression_methods = [?NULL], extensions = #hello_extensions{} }. - -enc_handshake(#hello_request{}, _Version) -> - {?HELLO_REQUEST, <<>>}; -enc_handshake(#client_hello{client_version = {Major, Minor}, - random = Random, - session_id = SessionID, - cipher_suites = CipherSuites, - compression_methods = CompMethods, - extensions = HelloExtensions}, _Version) -> - SIDLength = byte_size(SessionID), - BinCompMethods = list_to_binary(CompMethods), - CmLength = byte_size(BinCompMethods), - BinCipherSuites = list_to_binary(CipherSuites), - CsLength = byte_size(BinCipherSuites), - ExtensionsBin = ssl_handshake:encode_hello_extensions(HelloExtensions), - - {?CLIENT_HELLO, <<?BYTE(Major), ?BYTE(Minor), Random:32/binary, - ?BYTE(SIDLength), SessionID/binary, - ?UINT16(CsLength), BinCipherSuites/binary, - ?BYTE(CmLength), BinCompMethods/binary, ExtensionsBin/binary>>}; - -enc_handshake(HandshakeMsg, Version) -> - ssl_handshake:encode_handshake(HandshakeMsg, Version). - - -handle_client_hello_extensions(Version, Type, Random, CipherSuites, - HelloExt, SslOpts, Session0, ConnectionStates0, Renegotiation, HashSign) -> - try ssl_handshake:handle_client_hello_extensions(tls_record, Random, CipherSuites, - HelloExt, Version, SslOpts, - Session0, ConnectionStates0, Renegotiation) of - #alert{} = Alert -> - Alert; - {Session, ConnectionStates, Protocol, ServerHelloExt} -> - {Version, {Type, Session}, ConnectionStates, Protocol, ServerHelloExt, HashSign} - catch throw:Alert -> - Alert - end. - - -handle_server_hello_extensions(Version, SessionId, Random, CipherSuite, - Compression, HelloExt, SslOpt, ConnectionStates0, Renegotiation) -> - case ssl_handshake:handle_server_hello_extensions(tls_record, Random, CipherSuite, - Compression, HelloExt, Version, - SslOpt, ConnectionStates0, Renegotiation) of - #alert{} = Alert -> - Alert; - {ConnectionStates, ProtoExt, Protocol} -> - {Version, SessionId, ConnectionStates, ProtoExt, Protocol} - end. - diff --git a/lib/ssl/src/tls_record.erl b/lib/ssl/src/tls_record.erl index 4ac6cdc6b5..188ec6809d 100644 --- a/lib/ssl/src/tls_record.erl +++ b/lib/ssl/src/tls_record.erl @@ -32,22 +32,22 @@ -include("ssl_cipher.hrl"). %% Handling of incoming data --export([get_tls_records/2, init_connection_states/2]). +-export([get_tls_records/3, init_connection_states/2]). %% Encoding TLS records -export([encode_handshake/3, encode_alert_record/3, encode_change_cipher_spec/2, encode_data/3]). -export([encode_plain_text/4]). +%% Decoding +-export([decode_cipher_text/3]). + %% Protocol version handling -export([protocol_version/1, lowest_protocol_version/1, lowest_protocol_version/2, highest_protocol_version/1, highest_protocol_version/2, is_higher/2, supported_protocol_versions/0, is_acceptable_version/1, is_acceptable_version/2, hello_version/2]). -%% Decoding --export([decode_cipher_text/3]). - -export_type([tls_version/0, tls_atom_version/0]). -type tls_version() :: ssl_record:ssl_version(). @@ -56,13 +56,12 @@ -compile(inline). %%==================================================================== -%% Internal application API +%% Handling of incoming data %%==================================================================== %%-------------------------------------------------------------------- -spec init_connection_states(client | server, one_n_minus_one | zero_n | disabled) -> ssl_record:connection_states(). -%% % - % +%% %% Description: Creates a connection_states record with appropriate %% values for the initial SSL connection setup. %%-------------------------------------------------------------------- @@ -76,16 +75,29 @@ init_connection_states(Role, BeastMitigation) -> pending_write => Pending}. %%-------------------------------------------------------------------- --spec get_tls_records(binary(), binary()) -> {[binary()], binary()} | #alert{}. +-spec get_tls_records(binary(), [tls_version()], binary()) -> {[binary()], binary()} | #alert{}. %% %% and returns it as a list of tls_compressed binaries also returns leftover %% Description: Given old buffer and new data from TCP, packs up a records %% data %%-------------------------------------------------------------------- -get_tls_records(Data, <<>>) -> - get_tls_records_aux(Data, []); -get_tls_records(Data, Buffer) -> - get_tls_records_aux(list_to_binary([Buffer, Data]), []). +get_tls_records(Data, Versions, Buffer) -> + BinData = list_to_binary([Buffer, Data]), + case erlang:byte_size(BinData) of + N when N >= 3 -> + case assert_version(BinData, Versions) of + true -> + get_tls_records_aux(BinData, []); + false -> + ?ALERT_REC(?FATAL, ?BAD_RECORD_MAC) + end; + _ -> + get_tls_records_aux(BinData, []) + end. + +%%==================================================================== +%% Encoding +%%==================================================================== %%-------------------------------------------------------------------- -spec encode_handshake(iolist(), tls_version(), ssl_record:connection_states()) -> @@ -141,6 +153,74 @@ encode_data(Frag, Version, Data = split_bin(Frag, ?MAX_PLAIN_TEXT_LENGTH, Version, BCA, BeastMitigation), encode_iolist(?APPLICATION_DATA, Data, Version, ConnectionStates). +%%==================================================================== +%% Decoding +%%==================================================================== + +%%-------------------------------------------------------------------- +-spec decode_cipher_text(#ssl_tls{}, ssl_record:connection_states(), boolean()) -> + {#ssl_tls{}, ssl_record:connection_states()}| #alert{}. +%% +%% Description: Decode cipher text +%%-------------------------------------------------------------------- +decode_cipher_text(#ssl_tls{type = Type, version = Version, + fragment = CipherFragment} = CipherText, + #{current_read := + #{compression_state := CompressionS0, + sequence_number := Seq, + cipher_state := CipherS0, + security_parameters := + #security_parameters{ + cipher_type = ?AEAD, + bulk_cipher_algorithm = + BulkCipherAlgo, + compression_algorithm = CompAlg} + } = ReadState0} = ConnnectionStates0, _) -> + AAD = calc_aad(Type, Version, ReadState0), + case ssl_cipher:decipher_aead(BulkCipherAlgo, CipherS0, Seq, AAD, CipherFragment, Version) of + {PlainFragment, CipherS1} -> + {Plain, CompressionS1} = ssl_record:uncompress(CompAlg, + PlainFragment, CompressionS0), + ConnnectionStates = ConnnectionStates0#{ + current_read => ReadState0#{ + cipher_state => CipherS1, + sequence_number => Seq + 1, + compression_state => CompressionS1}}, + {CipherText#ssl_tls{fragment = Plain}, ConnnectionStates}; + #alert{} = Alert -> + Alert + end; + +decode_cipher_text(#ssl_tls{type = Type, version = Version, + fragment = CipherFragment} = CipherText, + #{current_read := + #{compression_state := CompressionS0, + sequence_number := Seq, + security_parameters := + #security_parameters{compression_algorithm = CompAlg} + } = ReadState0} = ConnnectionStates0, PaddingCheck) -> + case ssl_record:decipher(Version, CipherFragment, ReadState0, PaddingCheck) of + {PlainFragment, Mac, ReadState1} -> + MacHash = ssl_cipher:calc_mac_hash(Type, Version, PlainFragment, ReadState1), + case ssl_record:is_correct_mac(Mac, MacHash) of + true -> + {Plain, CompressionS1} = ssl_record:uncompress(CompAlg, + PlainFragment, CompressionS0), + ConnnectionStates = ConnnectionStates0#{ + current_read => ReadState1#{ + sequence_number => Seq + 1, + compression_state => CompressionS1}}, + {CipherText#ssl_tls{fragment = Plain}, ConnnectionStates}; + false -> + ?ALERT_REC(?FATAL, ?BAD_RECORD_MAC) + end; + #alert{} = Alert -> + Alert + end. + +%%==================================================================== +%% Protocol version handling +%%==================================================================== %%-------------------------------------------------------------------- -spec protocol_version(tls_atom_version() | tls_version()) -> @@ -278,11 +358,6 @@ supported_protocol_versions([_|_] = Vsns) -> end end. -%%-------------------------------------------------------------------- -%% -%% Description: ssl version 2 is not acceptable security risks are too big. -%% -%%-------------------------------------------------------------------- -spec is_acceptable_version(tls_version()) -> boolean(). is_acceptable_version({N,_}) when N >= ?LOWEST_MAJOR_SUPPORTED_VERSION -> @@ -302,6 +377,7 @@ hello_version(Version, _) when Version >= {3, 3} -> Version; hello_version(_, Versions) -> lowest_protocol_version(Versions). + %%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- @@ -318,6 +394,19 @@ initial_connection_state(ConnectionEnd, BeastMitigation) -> server_verify_data => undefined }. +assert_version(<<1:1, Length0:15, Data0:Length0/binary, _/binary>>, Versions) -> + case Data0 of + <<?BYTE(?CLIENT_HELLO), ?BYTE(Major), ?BYTE(Minor), _/binary>> -> + %% First check v2_hello_compatible mode is active + lists:member({2,0}, Versions) andalso + %% andalso we want to negotiate higher version + lists:member({Major, Minor}, Versions -- [{2,0}]); + _ -> + false + end; +assert_version(<<?BYTE(_), ?BYTE(MajVer), ?BYTE(MinVer), _/binary>>, Versions) -> + is_acceptable_version({MajVer, MinVer}, Versions). + get_tls_records_aux(<<?BYTE(?APPLICATION_DATA),?BYTE(MajVer),?BYTE(MinVer), ?UINT16(Length), Data:Length/binary, Rest/binary>>, Acc) -> @@ -361,10 +450,9 @@ get_tls_records_aux(<<1:1, Length0:15, Data0:Length0/binary, Rest/binary>>, end; get_tls_records_aux(<<0:1, _CT:7, ?BYTE(_MajVer), ?BYTE(_MinVer), - ?UINT16(Length), _/binary>>, + ?UINT16(Length), _/binary>>, _Acc) when Length > ?MAX_CIPHER_TEXT_LENGTH -> ?ALERT_REC(?FATAL, ?RECORD_OVERFLOW); - get_tls_records_aux(<<1:1, Length0:15, _/binary>>,_Acc) when Length0 > ?MAX_CIPHER_TEXT_LENGTH -> ?ALERT_REC(?FATAL, ?RECORD_OVERFLOW); @@ -376,37 +464,17 @@ get_tls_records_aux(Data, Acc) -> false -> ?ALERT_REC(?FATAL, ?UNEXPECTED_MESSAGE) end. - +%%-------------------------------------------------------------------- encode_plain_text(Type, Version, Data, #{current_write := Write0} = ConnectionStates) -> {CipherFragment, Write1} = do_encode_plain_text(Type, Version, Data, Write0), {CipherText, Write} = encode_tls_cipher_text(Type, Version, CipherFragment, Write1), {CipherText, ConnectionStates#{current_write => Write}}. -lowest_list_protocol_version(Ver, []) -> - Ver; -lowest_list_protocol_version(Ver1, [Ver2 | Rest]) -> - lowest_list_protocol_version(lowest_protocol_version(Ver1, Ver2), Rest). - -highest_list_protocol_version(Ver, []) -> - Ver; -highest_list_protocol_version(Ver1, [Ver2 | Rest]) -> - highest_list_protocol_version(highest_protocol_version(Ver1, Ver2), Rest). - encode_tls_cipher_text(Type, {MajVer, MinVer}, Fragment, #{sequence_number := Seq} = Write) -> Length = erlang:iolist_size(Fragment), {[<<?BYTE(Type), ?BYTE(MajVer), ?BYTE(MinVer), ?UINT16(Length)>>, Fragment], Write#{sequence_number => Seq +1}}. -highest_protocol_version() -> - highest_protocol_version(supported_protocol_versions()). - -lowest_protocol_version() -> - lowest_protocol_version(supported_protocol_versions()). - -sufficient_tlsv1_2_crypto_support() -> - CryptoSupport = crypto:supports(), - proplists:get_bool(sha256, proplists:get_value(hashs, CryptoSupport)). - encode_iolist(Type, Data, Version, ConnectionStates0) -> {ConnectionStates, EncodedMsg} = lists:foldl(fun(Text, {CS0, Encoded}) -> @@ -415,6 +483,31 @@ encode_iolist(Type, Data, Version, ConnectionStates0) -> {CS1, [Enc | Encoded]} end, {ConnectionStates0, []}, Data), {lists:reverse(EncodedMsg), ConnectionStates}. +%%-------------------------------------------------------------------- +do_encode_plain_text(Type, Version, Data, #{compression_state := CompS0, + security_parameters := + #security_parameters{ + cipher_type = ?AEAD, + compression_algorithm = CompAlg} + } = WriteState0) -> + {Comp, CompS1} = ssl_record:compress(CompAlg, Data, CompS0), + WriteState1 = WriteState0#{compression_state => CompS1}, + AAD = calc_aad(Type, Version, WriteState1), + ssl_record:cipher_aead(Version, Comp, WriteState1, AAD); +do_encode_plain_text(Type, Version, Data, #{compression_state := CompS0, + security_parameters := + #security_parameters{compression_algorithm = CompAlg} + }= WriteState0) -> + {Comp, CompS1} = ssl_record:compress(CompAlg, Data, CompS0), + WriteState1 = WriteState0#{compression_state => CompS1}, + MacHash = ssl_cipher:calc_mac_hash(Type, Version, Comp, WriteState1), + ssl_record:cipher(Version, Comp, WriteState1, MacHash); +do_encode_plain_text(_,_,_,CS) -> + exit({cs, CS}). +%%-------------------------------------------------------------------- +calc_aad(Type, {MajVer, MinVer}, + #{sequence_number := SeqNo}) -> + <<?UINT64(SeqNo), ?BYTE(Type), ?BYTE(MajVer), ?BYTE(MinVer)>>. %% 1/n-1 splitting countermeasure Rizzo/Duong-Beast, RC4 chiphers are %% not vulnerable to this attack. @@ -440,89 +533,25 @@ do_split_bin(Bin, ChunkSize, Acc) -> _ -> lists:reverse(Acc, [Bin]) end. - %%-------------------------------------------------------------------- --spec decode_cipher_text(#ssl_tls{}, ssl_record:connection_states(), boolean()) -> - {#ssl_tls{}, ssl_record:connection_states()}| #alert{}. -%% -%% Description: Decode cipher text -%%-------------------------------------------------------------------- -decode_cipher_text(#ssl_tls{type = Type, version = Version, - fragment = CipherFragment} = CipherText, - #{current_read := - #{compression_state := CompressionS0, - sequence_number := Seq, - cipher_state := CipherS0, - security_parameters := - #security_parameters{ - cipher_type = ?AEAD, - bulk_cipher_algorithm = - BulkCipherAlgo, - compression_algorithm = CompAlg} - } = ReadState0} = ConnnectionStates0, _) -> - AAD = calc_aad(Type, Version, ReadState0), - case ssl_cipher:decipher_aead(BulkCipherAlgo, CipherS0, Seq, AAD, CipherFragment, Version) of - {PlainFragment, CipherS1} -> - {Plain, CompressionS1} = ssl_record:uncompress(CompAlg, - PlainFragment, CompressionS0), - ConnnectionStates = ConnnectionStates0#{ - current_read => ReadState0#{ - cipher_state => CipherS1, - sequence_number => Seq + 1, - compression_state => CompressionS1}}, - {CipherText#ssl_tls{fragment = Plain}, ConnnectionStates}; - #alert{} = Alert -> - Alert - end; +lowest_list_protocol_version(Ver, []) -> + Ver; +lowest_list_protocol_version(Ver1, [Ver2 | Rest]) -> + lowest_list_protocol_version(lowest_protocol_version(Ver1, Ver2), Rest). -decode_cipher_text(#ssl_tls{type = Type, version = Version, - fragment = CipherFragment} = CipherText, - #{current_read := - #{compression_state := CompressionS0, - sequence_number := Seq, - security_parameters := - #security_parameters{compression_algorithm = CompAlg} - } = ReadState0} = ConnnectionStates0, PaddingCheck) -> - case ssl_record:decipher(Version, CipherFragment, ReadState0, PaddingCheck) of - {PlainFragment, Mac, ReadState1} -> - MacHash = ssl_cipher:calc_mac_hash(Type, Version, PlainFragment, ReadState1), - case ssl_record:is_correct_mac(Mac, MacHash) of - true -> - {Plain, CompressionS1} = ssl_record:uncompress(CompAlg, - PlainFragment, CompressionS0), - ConnnectionStates = ConnnectionStates0#{ - current_read => ReadState1#{ - sequence_number => Seq + 1, - compression_state => CompressionS1}}, - {CipherText#ssl_tls{fragment = Plain}, ConnnectionStates}; - false -> - ?ALERT_REC(?FATAL, ?BAD_RECORD_MAC) - end; - #alert{} = Alert -> - Alert - end. +highest_list_protocol_version(Ver, []) -> + Ver; +highest_list_protocol_version(Ver1, [Ver2 | Rest]) -> + highest_list_protocol_version(highest_protocol_version(Ver1, Ver2), Rest). + +highest_protocol_version() -> + highest_protocol_version(supported_protocol_versions()). + +lowest_protocol_version() -> + lowest_protocol_version(supported_protocol_versions()). + +sufficient_tlsv1_2_crypto_support() -> + CryptoSupport = crypto:supports(), + proplists:get_bool(sha256, proplists:get_value(hashs, CryptoSupport)). -do_encode_plain_text(Type, Version, Data, #{compression_state := CompS0, - security_parameters := - #security_parameters{ - cipher_type = ?AEAD, - compression_algorithm = CompAlg} - } = WriteState0) -> - {Comp, CompS1} = ssl_record:compress(CompAlg, Data, CompS0), - WriteState1 = WriteState0#{compression_state => CompS1}, - AAD = calc_aad(Type, Version, WriteState1), - ssl_record:cipher_aead(Version, Comp, WriteState1, AAD); -do_encode_plain_text(Type, Version, Data, #{compression_state := CompS0, - security_parameters := - #security_parameters{compression_algorithm = CompAlg} - }= WriteState0) -> - {Comp, CompS1} = ssl_record:compress(CompAlg, Data, CompS0), - WriteState1 = WriteState0#{compression_state => CompS1}, - MacHash = ssl_cipher:calc_mac_hash(Type, Version, Comp, WriteState1), - ssl_record:cipher(Version, Comp, WriteState1, MacHash); -do_encode_plain_text(_,_,_,CS) -> - exit({cs, CS}). -calc_aad(Type, {MajVer, MinVer}, - #{sequence_number := SeqNo}) -> - <<?UINT64(SeqNo), ?BYTE(Type), ?BYTE(MajVer), ?BYTE(MinVer)>>. diff --git a/lib/ssl/src/tls_v1.erl b/lib/ssl/src/tls_v1.erl index a8fe119bf8..a31ab8d044 100644 --- a/lib/ssl/src/tls_v1.erl +++ b/lib/ssl/src/tls_v1.erl @@ -202,23 +202,13 @@ suites(Minor) when Minor == 1; Minor == 2 -> ?TLS_DHE_DSS_WITH_AES_256_CBC_SHA, ?TLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA, ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA, - ?TLS_RSA_WITH_AES_256_CBC_SHA, ?TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA, ?TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA, ?TLS_DHE_RSA_WITH_AES_128_CBC_SHA, ?TLS_DHE_DSS_WITH_AES_128_CBC_SHA, ?TLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA, - ?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA, - ?TLS_RSA_WITH_AES_128_CBC_SHA, - - ?TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA, - ?TLS_ECDH_ECDSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_ECDH_RSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_RSA_WITH_3DES_EDE_CBC_SHA + ?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA ]; suites(3) -> [?TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384, @@ -230,16 +220,10 @@ suites(3) -> ?TLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA384, ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384, - ?TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256, - ?TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256, - ?TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256, - ?TLS_DHE_RSA_WITH_AES_256_GCM_SHA384, ?TLS_DHE_DSS_WITH_AES_256_GCM_SHA384, ?TLS_DHE_RSA_WITH_AES_256_CBC_SHA256, ?TLS_DHE_DSS_WITH_AES_256_CBC_SHA256, - ?TLS_RSA_WITH_AES_256_GCM_SHA384, - ?TLS_RSA_WITH_AES_256_CBC_SHA256, ?TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256, ?TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256, @@ -253,9 +237,7 @@ suites(3) -> ?TLS_DHE_RSA_WITH_AES_128_GCM_SHA256, ?TLS_DHE_DSS_WITH_AES_128_GCM_SHA256, ?TLS_DHE_RSA_WITH_AES_128_CBC_SHA256, - ?TLS_DHE_DSS_WITH_AES_128_CBC_SHA256, - ?TLS_RSA_WITH_AES_128_GCM_SHA256, - ?TLS_RSA_WITH_AES_128_CBC_SHA256 + ?TLS_DHE_DSS_WITH_AES_128_CBC_SHA256 %% not supported %% ?TLS_DH_RSA_WITH_AES_256_GCM_SHA384, @@ -264,8 +246,6 @@ suites(3) -> %% ?TLS_DH_DSS_WITH_AES_128_GCM_SHA256 ] ++ suites(2). - - signature_algs({3, 3}, HashSigns) -> CryptoSupports = crypto:supports(), Hashes = proplists:get_value(hashs, CryptoSupports), diff --git a/lib/ssl/test/Makefile b/lib/ssl/test/Makefile index c7e2f402af..9347b56f39 100644 --- a/lib/ssl/test/Makefile +++ b/lib/ssl/test/Makefile @@ -37,6 +37,8 @@ VSN=$(GS_VSN) MODULES = \ ssl_test_lib \ + ssl_bench_test_lib \ + ssl_dist_test_lib \ ssl_alpn_handshake_SUITE \ ssl_basic_SUITE \ ssl_bench_SUITE \ @@ -44,6 +46,8 @@ MODULES = \ ssl_certificate_verify_SUITE\ ssl_crl_SUITE\ ssl_dist_SUITE \ + ssl_dist_bench_SUITE \ + ssl_engine_SUITE\ ssl_handshake_SUITE \ ssl_npn_hello_SUITE \ ssl_npn_handshake_SUITE \ @@ -61,7 +65,8 @@ MODULES = \ ERL_FILES = $(MODULES:%=%.erl) -HRL_FILES = +HRL_FILES = \ + ssl_dist_test_lib.hrl HRL_FILES_SRC = \ ssl_api.hrl\ diff --git a/lib/ssl/test/ssl.spec b/lib/ssl/test/ssl.spec index 0ad94e22bc..cb54168d36 100644 --- a/lib/ssl/test/ssl.spec +++ b/lib/ssl/test/ssl.spec @@ -1,5 +1,4 @@ {suites,"../ssl_test",all}. -{skip_cases, "../ssl_test", - ssl_bench_SUITE, [setup_sequential, setup_concurrent, payload_simple, - use_pem_cache, bypass_pem_cache], - "Benchmarks run separately"}. +{skip_suites, "../ssl_test", + [ssl_bench_SUITE, ssl_dist_bench_SUITE], + "Benchmarks run separately"}. diff --git a/lib/ssl/test/ssl_basic_SUITE.erl b/lib/ssl/test/ssl_basic_SUITE.erl index 3b4ca40058..f13bd53a7c 100644 --- a/lib/ssl/test/ssl_basic_SUITE.erl +++ b/lib/ssl/test/ssl_basic_SUITE.erl @@ -213,6 +213,8 @@ cipher_tests() -> ciphers_rsa_signed_certs_openssl_names, ciphers_dsa_signed_certs, ciphers_dsa_signed_certs_openssl_names, + chacha_rsa_cipher_suites, + chacha_ecdsa_cipher_suites, anonymous_cipher_suites, psk_cipher_suites, psk_with_hint_cipher_suites, @@ -280,8 +282,11 @@ end_per_suite(_Config) -> init_per_group(GroupName, Config) when GroupName == basic_tls; GroupName == options_tls; + GroupName == options; GroupName == basic; - GroupName == options -> + GroupName == session; + GroupName == error_handling_tests_tls + -> ssl_test_lib:clean_tls_version(Config); init_per_group(GroupName, Config) -> case ssl_test_lib:is_tls_version(GroupName) andalso ssl_test_lib:sufficient_crypto_support(GroupName) of @@ -381,12 +386,12 @@ init_per_testcase(TestCase, Config) when TestCase == psk_cipher_suites; TestCase == anonymous_cipher_suites; TestCase == psk_anon_cipher_suites; TestCase == psk_anon_with_hint_cipher_suites; - TestCase == srp_cipher_suites, - TestCase == srp_anon_cipher_suites, - TestCase == srp_dsa_cipher_suites, - TestCase == des_rsa_cipher_suites, - TestCase == des_ecdh_rsa_cipher_suites, - TestCase == versions_option, + TestCase == srp_cipher_suites; + TestCase == srp_anon_cipher_suites; + TestCase == srp_dsa_cipher_suites; + TestCase == des_rsa_cipher_suites; + TestCase == des_ecdh_rsa_cipher_suites; + TestCase == versions_option; TestCase == tls_tcp_connect_big -> ssl_test_lib:ct_log_supported_protocol_versions(Config), ct:timetrap({seconds, 60}), @@ -427,6 +432,12 @@ init_per_testcase(rizzo_disabled, Config) -> ct:timetrap({seconds, 60}), rizzo_add_mitigation_option(disabled, Config); +init_per_testcase(TestCase, Config) when TestCase == no_reuses_session_server_restart_new_cert_file; + TestCase == no_reuses_session_server_restart_new_cert -> + ct:log("TLS/SSL version ~p~n ", [tls_record:supported_protocol_versions()]), + ct:timetrap({seconds, 15}), + Config; + init_per_testcase(prf, Config) -> ct:log("TLS/SSL version ~p~n ", [tls_record:supported_protocol_versions()]), ct:timetrap({seconds, 40}), @@ -655,7 +666,7 @@ connection_info(Config) when is_list(Config) -> {from, self()}, {mfa, {?MODULE, connection_info_result, []}}, {options, - [{ciphers,[{rsa, aes_128_cbc, sha}]} | + [{ciphers,[{dhe_rsa, aes_128_cbc, sha}]} | ClientOpts]}]), ct:log("Testcase ~p, Client ~p Server ~p ~n", @@ -663,7 +674,7 @@ connection_info(Config) when is_list(Config) -> Version = ssl_test_lib:protocol_version(Config), - ServerMsg = ClientMsg = {ok, {Version, {rsa, aes_128_cbc, sha}}}, + ServerMsg = ClientMsg = {ok, {Version, {dhe_rsa, aes_128_cbc, sha}}}, ssl_test_lib:check_result(Server, ServerMsg, Client, ClientMsg), @@ -1278,9 +1289,14 @@ cipher_suites() -> [{doc,"Test API function cipher_suites/0"}]. cipher_suites(Config) when is_list(Config) -> - MandatoryCipherSuite = {rsa,'3des_ede_cbc',sha}, - [_|_] = Suites = ssl:cipher_suites(), - true = lists:member(MandatoryCipherSuite, Suites), + MandatoryCipherSuiteTLS1_0TLS1_1 = {rsa,'3des_ede_cbc',sha}, + MandatoryCipherSuiteTLS1_0TLS1_2 = {rsa,'aes_128_cbc',sha} , + [_|_] = Suites = ssl:cipher_suites(), + AllSuites = ssl:cipher_suites(all), + %% The mandantory suites will no longer be supported by default + %% due to security reasons + true = lists:member(MandatoryCipherSuiteTLS1_0TLS1_1, AllSuites), + true = lists:member(MandatoryCipherSuiteTLS1_0TLS1_2, AllSuites), Suites = ssl:cipher_suites(erlang), [_|_] =ssl:cipher_suites(openssl). @@ -1289,7 +1305,7 @@ cipher_suites_mix() -> [{doc,"Test to have old and new cipher suites at the same time"}]. cipher_suites_mix(Config) when is_list(Config) -> - CipherSuites = [{ecdh_rsa,aes_128_cbc,sha256,sha256}, {rsa,aes_128_cbc,sha}], + CipherSuites = [{dhe_rsa,aes_128_cbc,sha256,sha256}, {dhe_rsa,aes_128_cbc,sha}], ClientOpts = ssl_test_lib:ssl_options(client_verification_opts, Config), ServerOpts = ssl_test_lib:ssl_options(server_verification_opts, Config), @@ -2357,7 +2373,24 @@ ciphers_dsa_signed_certs_openssl_names() -> ciphers_dsa_signed_certs_openssl_names(Config) when is_list(Config) -> Ciphers = ssl_test_lib:openssl_dsa_suites(), run_suites(Ciphers, Config, dsa). + +%%------------------------------------------------------------------- +chacha_rsa_cipher_suites()-> + [{doc,"Test the cacha with ECDSA signed certs ciphersuites"}]. +chacha_rsa_cipher_suites(Config) when is_list(Config) -> + NVersion = ssl_test_lib:protocol_version(Config, tuple), + Ciphers = [S || {KeyEx,_,_} = S <- ssl_test_lib:chacha_suites(NVersion), + KeyEx == ecdhe_rsa, KeyEx == dhe_rsa], + run_suites(Ciphers, Config, chacha_ecdsa). + %%------------------------------------------------------------------- +chacha_ecdsa_cipher_suites()-> + [{doc,"Test the cacha with ECDSA signed certs ciphersuites"}]. +chacha_ecdsa_cipher_suites(Config) when is_list(Config) -> + NVersion = ssl_test_lib:protocol_version(Config, tuple), + Ciphers = [S || {ecdhe_ecdsa,_,_} = S <- ssl_test_lib:chacha_suites(NVersion)], + run_suites(Ciphers, Config, chacha_rsa). +%%----------------------------------------------------------------- anonymous_cipher_suites()-> [{doc,"Test the anonymous ciphersuites"}]. anonymous_cipher_suites(Config) when is_list(Config) -> @@ -2437,14 +2470,15 @@ rc4_ecdsa_cipher_suites(Config) when is_list(Config) -> des_rsa_cipher_suites()-> [{doc, "Test the des_rsa ciphersuites"}]. des_rsa_cipher_suites(Config) when is_list(Config) -> - Ciphers = ssl_test_lib:des_suites(Config), + NVersion = tls_record:highest_protocol_version([]), + Ciphers = [S || {rsa,_,_} = S <- ssl_test_lib:des_suites(NVersion)], run_suites(Ciphers, Config, des_rsa). %------------------------------------------------------------------- des_ecdh_rsa_cipher_suites()-> [{doc, "Test ECDH rsa signed ciphersuites"}]. des_ecdh_rsa_cipher_suites(Config) when is_list(Config) -> NVersion = ssl_test_lib:protocol_version(Config, tuple), - Ciphers = ssl_test_lib:des_suites(NVersion), + Ciphers = [S || {dhe_rsa,_,_} = S <- ssl_test_lib:des_suites(NVersion)], run_suites(Ciphers, Config, des_dhe_rsa). %%-------------------------------------------------------------------- @@ -3137,18 +3171,25 @@ no_reuses_session_server_restart_new_cert_file(Config) when is_list(Config) -> %%-------------------------------------------------------------------- defaults(Config) when is_list(Config)-> - [_, - {supported, Supported}, - {available, Available}] - = ssl:versions(), - true = lists:member(sslv3, Available), - false = lists:member(sslv3, Supported), + Versions = ssl:versions(), + true = lists:member(sslv3, proplists:get_value(available, Versions)), + false = lists:member(sslv3, proplists:get_value(supported, Versions)), + true = lists:member('tlsv1', proplists:get_value(available, Versions)), + true = lists:member('tlsv1', proplists:get_value(supported, Versions)), + true = lists:member('tlsv1.1', proplists:get_value(available, Versions)), + true = lists:member('tlsv1.1', proplists:get_value(supported, Versions)), + true = lists:member('tlsv1.2', proplists:get_value(available, Versions)), + true = lists:member('tlsv1.2', proplists:get_value(supported, Versions)), false = lists:member({rsa,rc4_128,sha}, ssl:cipher_suites()), true = lists:member({rsa,rc4_128,sha}, ssl:cipher_suites(all)), false = lists:member({rsa,des_cbc,sha}, ssl:cipher_suites()), true = lists:member({rsa,des_cbc,sha}, ssl:cipher_suites(all)), false = lists:member({dhe_rsa,des_cbc,sha}, ssl:cipher_suites()), - true = lists:member({dhe_rsa,des_cbc,sha}, ssl:cipher_suites(all)). + true = lists:member({dhe_rsa,des_cbc,sha}, ssl:cipher_suites(all)), + true = lists:member('dtlsv1.2', proplists:get_value(available_dtls, Versions)), + true = lists:member('dtlsv1', proplists:get_value(available_dtls, Versions)), + true = lists:member('dtlsv1.2', proplists:get_value(supported_dtls, Versions)), + true = lists:member('dtlsv1', proplists:get_value(supported_dtls, Versions)). %%-------------------------------------------------------------------- reuseaddr() -> @@ -3234,16 +3275,16 @@ tls_tcp_reuseaddr(Config) when is_list(Config) -> honor_server_cipher_order() -> [{doc,"Test API honor server cipher order."}]. honor_server_cipher_order(Config) when is_list(Config) -> - ClientCiphers = [{rsa, aes_128_cbc, sha}, {rsa, aes_256_cbc, sha}], - ServerCiphers = [{rsa, aes_256_cbc, sha}, {rsa, aes_128_cbc, sha}], -honor_cipher_order(Config, true, ServerCiphers, ClientCiphers, {rsa, aes_256_cbc, sha}). + ClientCiphers = [{dhe_rsa, aes_128_cbc, sha}, {dhe_rsa, aes_256_cbc, sha}], + ServerCiphers = [{dhe_rsa, aes_256_cbc, sha}, {dhe_rsa, aes_128_cbc, sha}], +honor_cipher_order(Config, true, ServerCiphers, ClientCiphers, {dhe_rsa, aes_256_cbc, sha}). honor_client_cipher_order() -> [{doc,"Test API honor server cipher order."}]. honor_client_cipher_order(Config) when is_list(Config) -> - ClientCiphers = [{rsa, aes_128_cbc, sha}, {rsa, aes_256_cbc, sha}], - ServerCiphers = [{rsa, aes_256_cbc, sha}, {rsa, aes_128_cbc, sha}], -honor_cipher_order(Config, false, ServerCiphers, ClientCiphers, {rsa, aes_128_cbc, sha}). + ClientCiphers = [{dhe_rsa, aes_128_cbc, sha}, {dhe_rsa, aes_256_cbc, sha}], + ServerCiphers = [{dhe_rsa, aes_256_cbc, sha}, {dhe_rsa, aes_128_cbc, sha}], +honor_cipher_order(Config, false, ServerCiphers, ClientCiphers, {dhe_rsa, aes_128_cbc, sha}). honor_cipher_order(Config, Honor, ServerCiphers, ClientCiphers, Expected) -> ClientOpts = ssl_test_lib:ssl_options(client_opts, Config), @@ -4600,38 +4641,39 @@ client_server_opts({KeyAlgo,_,_}, Config) when KeyAlgo == ecdh_rsa -> ssl_test_lib:ssl_options(server_ecdh_rsa_opts, Config)}. run_suites(Ciphers, Config, Type) -> - NVersion = ssl_test_lib:protocol_version(Config, tuple), Version = ssl_test_lib:protocol_version(Config), ct:log("Running cipher suites ~p~n", [Ciphers]), {ClientOpts, ServerOpts} = case Type of rsa -> {ssl_test_lib:ssl_options(client_verification_opts, Config), - ssl_test_lib:ssl_options(server_verification_opts, Config)}; + [{ciphers, Ciphers} | + ssl_test_lib:ssl_options(server_verification_opts, Config)]}; dsa -> {ssl_test_lib:ssl_options(client_verification_opts, Config), - ssl_test_lib:ssl_options(server_dsa_opts, Config)}; + [{ciphers, Ciphers} | + ssl_test_lib:ssl_options(server_dsa_opts, Config)]}; anonymous -> %% No certs in opts! {ssl_test_lib:ssl_options(client_verification_opts, Config), - [{reuseaddr, true}, {ciphers, ssl_test_lib:anonymous_suites(NVersion)} | + [{ciphers, Ciphers} | ssl_test_lib:ssl_options([], Config)]}; psk -> {ssl_test_lib:ssl_options(client_psk, Config), - [{ciphers, ssl_test_lib:psk_suites(NVersion)} | + [{ciphers, Ciphers} | ssl_test_lib:ssl_options(server_psk, Config)]}; psk_with_hint -> {ssl_test_lib:ssl_options(client_psk, Config), - [{ciphers, ssl_test_lib:psk_suites(NVersion)} | + [{ciphers, Ciphers} | ssl_test_lib:ssl_options(server_psk_hint, Config) ]}; psk_anon -> {ssl_test_lib:ssl_options(client_psk, Config), - [{ciphers, ssl_test_lib:psk_anon_suites(NVersion)} | + [{ciphers, Ciphers} | ssl_test_lib:ssl_options(server_psk_anon, Config)]}; psk_anon_with_hint -> {ssl_test_lib:ssl_options(client_psk, Config), - [{ciphers, ssl_test_lib:psk_anon_suites(NVersion)} | + [{ciphers, Ciphers} | ssl_test_lib:ssl_options(server_psk_anon_hint, Config)]}; srp -> {ssl_test_lib:ssl_options(client_srp, Config), @@ -4644,7 +4686,8 @@ run_suites(Ciphers, Config, Type) -> ssl_test_lib:ssl_options(server_srp_dsa, Config)}; ecdsa -> {ssl_test_lib:ssl_options(client_verification_opts, Config), - ssl_test_lib:ssl_options(server_ecdsa_opts, Config)}; + [{ciphers, Ciphers} | + ssl_test_lib:ssl_options(server_ecdsa_opts, Config)]}; ecdh_rsa -> {ssl_test_lib:ssl_options(client_verification_opts, Config), ssl_test_lib:ssl_options(server_ecdh_rsa_opts, Config)}; @@ -4667,9 +4710,16 @@ run_suites(Ciphers, Config, Type) -> des_rsa -> {ssl_test_lib:ssl_options(client_verification_opts, Config), [{ciphers, Ciphers} | - ssl_test_lib:ssl_options(server_verification_opts, Config)]} + ssl_test_lib:ssl_options(server_verification_opts, Config)]}; + chacha_rsa -> + {ssl_test_lib:ssl_options(client_verification_opts, Config), + [{ciphers, Ciphers} | + ssl_test_lib:ssl_options(server_verification_opts, Config)]}; + chacha_ecdsa -> + {ssl_test_lib:ssl_options(client_verification_opts, Config), + [{ciphers, Ciphers} | + ssl_test_lib:ssl_options(server_ecdsa_opts, Config)]} end, - Result = lists:map(fun(Cipher) -> cipher(Cipher, Version, Config, ClientOpts, ServerOpts) end, ssl_test_lib:filter_suites(Ciphers, Version)), diff --git a/lib/ssl/test/ssl_bench.spec b/lib/ssl/test/ssl_bench.spec index d2f75b4203..8b746c5ca9 100644 --- a/lib/ssl/test/ssl_bench.spec +++ b/lib/ssl/test/ssl_bench.spec @@ -1 +1 @@ -{suites,"../ssl_test",[ssl_bench_SUITE]}. +{suites,"../ssl_test",[ssl_bench_SUITE, ssl_dist_bench_SUITE]}. diff --git a/lib/ssl/test/ssl_bench_SUITE.erl b/lib/ssl/test/ssl_bench_SUITE.erl index ae2928b1c3..3fe6338d69 100644 --- a/lib/ssl/test/ssl_bench_SUITE.erl +++ b/lib/ssl/test/ssl_bench_SUITE.erl @@ -40,11 +40,11 @@ end_per_group(_GroupName, _Config) -> ok. init_per_suite(Config) -> - try - Server = setup(ssl, node()), - [{server_node, Server}|Config] - catch _:_ -> - {skipped, "Benchmark machines only"} + case node() of + nonode@nohost -> + {skipped, "Node not distributed"}; + _ -> + [{server_node, ssl_bench_test_lib:setup(perf_server)}|Config] end. end_per_suite(_Config) -> @@ -132,10 +132,10 @@ bypass_pem_cache(_Config) -> ssl() -> - test(ssl, ?COUNT, node()). + test(ssl, ?COUNT). -test(Type, Count, Host) -> - Server = setup(Type, Host), +test(Type, Count) -> + Server = ssl_bench_test_lib:setup(perf_server), (do_test(Type, setup_connection, Count * 20, 1, Server)), (do_test(Type, setup_connection, Count, 100, Server)), (do_test(Type, payload, Count*300, 10, Server)), @@ -294,47 +294,6 @@ msg() -> "asdlkjsafsdfoierwlejsdlkfjsdf">>. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -setup(_Type, nonode@nohost) -> - exit(dist_not_enabled); -setup(Type, _This) -> - Host = case os:getenv(?remote_host) of - false -> - {ok, This} = inet:gethostname(), - This; - RemHost -> - RemHost - end, - Node = list_to_atom("perf_server@" ++ Host), - SlaveArgs = case init:get_argument(pa) of - {ok, PaPaths} -> - lists:append([" -pa " ++ P || [P] <- PaPaths]); - _ -> [] - end, - %% io:format("Slave args: ~p~n",[SlaveArgs]), - Prog = - case os:find_executable("erl") of - false -> "erl"; - P -> P - end, - io:format("Prog = ~p~n", [Prog]), - - case net_adm:ping(Node) of - pong -> ok; - pang -> - {ok, Node} = slave:start(Host, perf_server, SlaveArgs, no_link, Prog) - end, - Path = code:get_path(), - true = rpc:call(Node, code, set_path, [Path]), - ok = rpc:call(Node, ?MODULE, setup_server, [Type, node()]), - io:format("Client (~p) using ~s~n",[node(), code:which(ssl)]), - (Node =:= node()) andalso restrict_schedulers(client), - Node. - -setup_server(_Type, ClientNode) -> - (ClientNode =:= node()) andalso restrict_schedulers(server), - io:format("Server (~p) using ~s~n",[node(), code:which(ssl)]), - ok. - ensure_all_started(App, Ack) -> case application:start(App) of @@ -358,13 +317,6 @@ setup_server_init(Type, Tc, Loop, PC) -> unlink(Pid), Res. -restrict_schedulers(Type) -> - %% We expect this to run on 8 core machine - Extra0 = 1, - Extra = if (Type =:= server) -> -Extra0; true -> Extra0 end, - Scheds = erlang:system_info(schedulers), - erlang:system_flag(schedulers_online, (Scheds div 2) + Extra). - tc(Fun, Mod, Line) -> case timer:tc(Fun) of {_,{'EXIT',Reason}} -> diff --git a/lib/ssl/test/ssl_bench_test_lib.erl b/lib/ssl/test/ssl_bench_test_lib.erl new file mode 100644 index 0000000000..e5cbb911bd --- /dev/null +++ b/lib/ssl/test/ssl_bench_test_lib.erl @@ -0,0 +1,75 @@ +%%%------------------------------------------------------------------- +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. 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(ssl_bench_test_lib). + +%% API +-export([setup/1]). + +%% Internal exports +-export([setup_server/1]). + +-define(remote_host, "NETMARKS_REMOTE_HOST"). + +setup(Name) -> + Host = case os:getenv(?remote_host) of + false -> + {ok, This} = inet:gethostname(), + This; + RemHost -> + RemHost + end, + Node = list_to_atom(atom_to_list(Name) ++ "@" ++ Host), + SlaveArgs = case init:get_argument(pa) of + {ok, PaPaths} -> + lists:append([" -pa " ++ P || [P] <- PaPaths]); + _ -> [] + end, + %% io:format("Slave args: ~p~n",[SlaveArgs]), + Prog = + case os:find_executable("erl") of + false -> "erl"; + P -> P + end, + io:format("Prog = ~p~n", [Prog]), + + case net_adm:ping(Node) of + pong -> ok; + pang -> + {ok, Node} = + slave:start(Host, Name, SlaveArgs, no_link, Prog) + end, + Path = code:get_path(), + true = rpc:call(Node, code, set_path, [Path]), + ok = rpc:call(Node, ?MODULE, setup_server, [node()]), + io:format("Client (~p) using ~s~n",[node(), code:which(ssl)]), + (Node =:= node()) andalso restrict_schedulers(client), + Node. + +setup_server(ClientNode) -> + (ClientNode =:= node()) andalso restrict_schedulers(server), + io:format("Server (~p) using ~s~n",[node(), code:which(ssl)]), + ok. + +restrict_schedulers(Type) -> + %% We expect this to run on 8 core machine + Extra0 = 1, + Extra = if (Type =:= server) -> -Extra0; true -> Extra0 end, + Scheds = erlang:system_info(schedulers), + erlang:system_flag(schedulers_online, (Scheds div 2) + Extra). diff --git a/lib/ssl/test/ssl_dist_SUITE.erl b/lib/ssl/test/ssl_dist_SUITE.erl index 8740e8c8f0..c822a52d1f 100644 --- a/lib/ssl/test/ssl_dist_SUITE.erl +++ b/lib/ssl/test/ssl_dist_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2007-2016. All Rights Reserved. +%% Copyright Ericsson AB 2007-2017. 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. @@ -22,6 +22,7 @@ -include_lib("common_test/include/ct.hrl"). -include_lib("public_key/include/public_key.hrl"). +-include("ssl_dist_test_lib.hrl"). %% Note: This directive should only be used in test suites. -compile(export_all). @@ -30,12 +31,12 @@ -define(AWAIT_SSL_NODE_UP_TIMEOUT, 30000). --record(node_handle, - {connection_handler, - socket, - name, - nodename} - ). +-import(ssl_dist_test_lib, + [tstsrvr_format/2, send_to_tstcntrl/1, + apply_on_ssl_node/4, apply_on_ssl_node/2, + stop_ssl_node/1]). +start_ssl_node_name(Name, Args) -> + ssl_dist_test_lib:start_ssl_node(Name, Args). %%-------------------------------------------------------------------- %% Common Test interface functions ----------------------------------- @@ -140,11 +141,14 @@ basic_test(NH1, NH2, _) -> apply_on_ssl_node( NH1, fun () -> - tstsrvr_format("Hi from ~p!~n", [node()]), - send_to_tstcntrl({Ref, self()}), + tstsrvr_format( + "Hi from ~p!~n", [node()]), + send_to_tstcntrl( + {Ref, self()}), receive {From, ping} -> - tstsrvr_format("Received ping ~p!~n", [node()]), + tstsrvr_format( + "Received ping ~p!~n", [node()]), From ! {self(), pong} end end) @@ -154,7 +158,8 @@ basic_test(NH1, NH2, _) -> ok = apply_on_ssl_node( NH2, fun () -> - tstsrvr_format("Hi from ~p!~n", [node()]), + tstsrvr_format( + "Hi from ~p!~n", [node()]), SslPid ! {self(), ping}, receive {SslPid, pong} -> @@ -183,7 +188,8 @@ payload_test(NH1, NH2, _) -> apply_on_ssl_node( NH1, fun () -> - send_to_tstcntrl({Ref, self()}), + send_to_tstcntrl( + {Ref, self()}), receive {From, Msg} -> From ! {self(), Msg} @@ -616,12 +622,6 @@ gen_dist_test(Test, Config) -> %% ssl_node side api %% -tstsrvr_format(Fmt, ArgList) -> - send_to_tstsrvr({format, Fmt, ArgList}). - -send_to_tstcntrl(Message) -> - send_to_tstsrvr({message, Message}). - try_setting_priority(TestFun, Config) -> Prio = 1, case gen_udp:open(0, [{priority,Prio}]) of @@ -653,44 +653,6 @@ inet_ports() -> %% test_server side api %% -apply_on_ssl_node(Node, M, F, A) when is_atom(M), is_atom(F), is_list(A) -> - Ref = make_ref(), - send_to_ssl_node(Node, {apply, self(), Ref, M, F, A}), - receive - {Ref, Result} -> - Result - end. - -apply_on_ssl_node(Node, Fun) when is_function(Fun, 0) -> - Ref = make_ref(), - send_to_ssl_node(Node, {apply, self(), Ref, Fun}), - receive - {Ref, Result} -> - Result - end. - -stop_ssl_node(#node_handle{connection_handler = Handler, - socket = Socket, - name = Name}) -> - ?t:format("Trying to stop ssl node ~s.~n", [Name]), - Mon = erlang:monitor(process, Handler), - unlink(Handler), - case gen_tcp:send(Socket, term_to_binary(stop)) of - ok -> - receive - {'DOWN', Mon, process, Handler, Reason} -> - case Reason of - normal -> - ok; - _ -> - ct:pal("Down ~p ~n", [Reason]) - end - end; - Error -> - erlang:demonitor(Mon, [flush]), - ct:pal("Warning ~p ~n", [Error]) - end. - start_ssl_node(Config) -> start_ssl_node(Config, ""). @@ -698,29 +660,8 @@ start_ssl_node(Config, XArgs) -> Name = mk_node_name(Config), SSL = proplists:get_value(ssl_opts, Config), SSLDistOpts = setup_dist_opts(Config), - start_ssl_node_raw(Name, SSL ++ " " ++ SSLDistOpts ++ XArgs). - -start_ssl_node_raw(Name, Args) -> - {ok, LSock} = gen_tcp:listen(0, - [binary, {packet, 4}, {active, false}]), - {ok, ListenPort} = inet:port(LSock), - CmdLine = mk_node_cmdline(ListenPort, Name, Args), - ?t:format("Attempting to start ssl node ~ts: ~ts~n", [Name, CmdLine]), - case open_port({spawn, CmdLine}, []) of - Port when is_port(Port) -> - unlink(Port), - erlang:port_close(Port), - case await_ssl_node_up(Name, LSock) of - #node_handle{} = NodeHandle -> - ?t:format("Ssl node ~s started.~n", [Name]), - NodeName = list_to_atom(Name ++ "@" ++ host_name()), - NodeHandle#node_handle{nodename = NodeName}; - Error -> - exit({failed_to_start_node, Name, Error}) - end; - Error -> - exit({failed_to_start_node, Name, Error}) - end. + start_ssl_node_name( + Name, SSL ++ " " ++ SSLDistOpts ++ XArgs). cache_crls_on_ssl_nodes(PrivDir, CANames, NHs) -> [begin @@ -739,11 +680,6 @@ cache_crls_on_ssl_nodes(PrivDir, CANames, NHs) -> %% command line creation %% -host_name() -> - [$@ | Host] = lists:dropwhile(fun ($@) -> false; (_) -> true end, - atom_to_list(node())), - Host. - mk_node_name(Config) -> N = erlang:unique_integer([positive]), Case = proplists:get_value(testcase, Config), @@ -753,225 +689,6 @@ mk_node_name(Config) -> ++ "_" ++ integer_to_list(N). -mk_node_cmdline(ListenPort, Name, Args) -> - Static = "-detached -noinput", - Pa = filename:dirname(code:which(?MODULE)), - Prog = case catch init:get_argument(progname) of - {ok,[[P]]} -> P; - _ -> exit(no_progname_argument_found) - end, - NameSw = case net_kernel:longnames() of - false -> "-sname "; - _ -> "-name " - end, - {ok, Pwd} = file:get_cwd(), - "\"" ++ Prog ++ "\" " - ++ Static ++ " " - ++ NameSw ++ " " ++ Name ++ " " - ++ "-pa " ++ Pa ++ " " - ++ "-run application start crypto -run application start public_key " - ++ "-eval 'net_kernel:verbose(1)' " - ++ "-run " ++ atom_to_list(?MODULE) ++ " cnct2tstsrvr " - ++ host_name() ++ " " - ++ integer_to_list(ListenPort) ++ " " - ++ Args ++ " " - ++ "-env ERL_CRASH_DUMP " ++ Pwd ++ "/erl_crash_dump." ++ Name ++ " " - ++ "-kernel error_logger \"{file,\\\"" ++ Pwd ++ "/error_log." ++ Name ++ "\\\"}\" " - ++ "-setcookie " ++ atom_to_list(erlang:get_cookie()). - -%% -%% Connection handler test_server side -%% - -await_ssl_node_up(Name, LSock) -> - case gen_tcp:accept(LSock, ?AWAIT_SSL_NODE_UP_TIMEOUT) of - timeout -> - gen_tcp:close(LSock), - ?t:format("Timeout waiting for ssl node ~s to come up~n", - [Name]), - timeout; - {ok, Socket} -> - gen_tcp:close(LSock), - case gen_tcp:recv(Socket, 0) of - {ok, Bin} -> - check_ssl_node_up(Socket, Name, Bin); - {error, closed} -> - gen_tcp:close(Socket), - exit({lost_connection_with_ssl_node_before_up, Name}) - end; - {error, Error} -> - gen_tcp:close(LSock), - exit({accept_failed, Error}) - end. - -check_ssl_node_up(Socket, Name, Bin) -> - case catch binary_to_term(Bin) of - {'EXIT', _} -> - gen_tcp:close(Socket), - exit({bad_data_received_from_ssl_node, Name, Bin}); - {ssl_node_up, NodeName} -> - case list_to_atom(Name++"@"++host_name()) of - NodeName -> - Parent = self(), - Go = make_ref(), - %% Spawn connection handler on test server side - Pid = spawn_link( - fun () -> - receive Go -> ok end, - tstsrvr_con_loop(Name, Socket, Parent) - end), - ok = gen_tcp:controlling_process(Socket, Pid), - Pid ! Go, - #node_handle{connection_handler = Pid, - socket = Socket, - name = Name}; - _ -> - exit({unexpected_ssl_node_connected, NodeName}) - end; - Msg -> - exit({unexpected_msg_instead_of_ssl_node_up, Name, Msg}) - end. - -send_to_ssl_node(#node_handle{connection_handler = Hndlr}, Term) -> - Hndlr ! {relay_to_ssl_node, term_to_binary(Term)}, - ok. - -tstsrvr_con_loop(Name, Socket, Parent) -> - inet:setopts(Socket,[{active,once}]), - receive - {relay_to_ssl_node, Data} when is_binary(Data) -> - case gen_tcp:send(Socket, Data) of - ok -> - ok; - _Error -> - gen_tcp:close(Socket), - exit({failed_to_relay_data_to_ssl_node, Name, Data}) - end; - {tcp, Socket, Bin} -> - case catch binary_to_term(Bin) of - {'EXIT', _} -> - gen_tcp:close(Socket), - exit({bad_data_received_from_ssl_node, Name, Bin}); - {format, FmtStr, ArgList} -> - ?t:format(FmtStr, ArgList); - {message, Msg} -> - ?t:format("Got message ~p", [Msg]), - Parent ! Msg; - {apply_res, To, Ref, Res} -> - To ! {Ref, Res}; - bye -> - ?t:format("Ssl node ~s stopped.~n", [Name]), - gen_tcp:close(Socket), - exit(normal); - Unknown -> - exit({unexpected_message_from_ssl_node, Name, Unknown}) - end; - {tcp_closed, Socket} -> - gen_tcp:close(Socket), - exit({lost_connection_with_ssl_node, Name}) - end, - tstsrvr_con_loop(Name, Socket, Parent). - -%% -%% Connection handler ssl_node side -%% - -% cnct2tstsrvr() is called via command line arg -run ... -cnct2tstsrvr([Host, Port]) when is_list(Host), is_list(Port) -> - %% Spawn connection handler on ssl node side - ConnHandler - = spawn(fun () -> - case catch gen_tcp:connect(Host, - list_to_integer(Port), - [binary, - {packet, 4}, - {active, false}]) of - {ok, Socket} -> - notify_ssl_node_up(Socket), - ets:new(test_server_info, - [set, - public, - named_table, - {keypos, 1}]), - ets:insert(test_server_info, - {test_server_handler, self()}), - ssl_node_con_loop(Socket); - Error -> - halt("Failed to connect to test server " ++ - lists:flatten(io_lib:format("Host:~p ~n Port:~p~n Error:~p~n", - [Host, Port, Error]))) - end - end), - spawn(fun () -> - Mon = erlang:monitor(process, ConnHandler), - receive - {'DOWN', Mon, process, ConnHandler, Reason} -> - receive after 1000 -> ok end, - halt("test server connection handler terminated: " ++ - lists:flatten(io_lib:format("~p", [Reason]))) - end - end). - -notify_ssl_node_up(Socket) -> - case catch gen_tcp:send(Socket, - term_to_binary({ssl_node_up, node()})) of - ok -> ok; - _ -> halt("Failed to notify test server that I'm up") - end. - -send_to_tstsrvr(Term) -> - case catch ets:lookup_element(test_server_info, test_server_handler, 2) of - Hndlr when is_pid(Hndlr) -> - Hndlr ! {relay_to_test_server, term_to_binary(Term)}, ok; - _ -> - receive after 200 -> ok end, - send_to_tstsrvr(Term) - end. - -ssl_node_con_loop(Socket) -> - inet:setopts(Socket,[{active,once}]), - receive - {relay_to_test_server, Data} when is_binary(Data) -> - case gen_tcp:send(Socket, Data) of - ok -> - ok; - _Error -> - gen_tcp:close(Socket), - halt("Failed to relay data to test server") - end; - {tcp, Socket, Bin} -> - case catch binary_to_term(Bin) of - {'EXIT', _} -> - gen_tcp:close(Socket), - halt("test server sent me bad data"); - {apply, From, Ref, M, F, A} -> - spawn_link( - fun () -> - send_to_tstsrvr({apply_res, - From, - Ref, - (catch apply(M, F, A))}) - end); - {apply, From, Ref, Fun} -> - spawn_link(fun () -> - send_to_tstsrvr({apply_res, - From, - Ref, - (catch Fun())}) - end); - stop -> - gen_tcp:send(Socket, term_to_binary(bye)), - gen_tcp:close(Socket), - init:stop(), - receive after infinity -> ok end; - _Unknown -> - halt("test server sent me an unexpected message") - end; - {tcp_closed, Socket} -> - halt("Lost connection to test server") - end, - ssl_node_con_loop(Socket). - %% %% Setup ssl dist info %% diff --git a/lib/ssl/test/ssl_dist_bench_SUITE.erl b/lib/ssl/test/ssl_dist_bench_SUITE.erl new file mode 100644 index 0000000000..4d27564319 --- /dev/null +++ b/lib/ssl/test/ssl_dist_bench_SUITE.erl @@ -0,0 +1,481 @@ +%%%------------------------------------------------------------------- +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. 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(ssl_dist_bench_SUITE). + +-include_lib("common_test/include/ct_event.hrl"). +-include_lib("public_key/include/public_key.hrl"). + +%% CT meta +-export([suite/0, all/0, groups/0, + init_per_suite/1, end_per_suite/1, + init_per_group/2, end_per_group/2, + init_per_testcase/2, end_per_testcase/2]). + +%% Test cases +-export( + [setup/1, + roundtrip/1, + throughput_1024/1, + throughput_4096/1, + throughput_16384/1, + throughput_65536/1, + throughput_262144/1, + throughput_1048576/1]). + +%% Debug +-export([payload/1]). + +%%%------------------------------------------------------------------- + +suite() -> [{ct_hooks, [{ts_install_cth, [{nodenames, 2}]}]}]. + +all() -> [{group, ssl}, {group, plain}]. + +groups() -> + [{ssl, all_groups()}, + {plain, all_groups()}, + %% + {setup, [{repeat, 1}], [setup]}, + {roundtrip, [{repeat, 1}], [roundtrip]}, + {throughput, [{repeat, 1}], + [throughput_1024, + throughput_4096, + throughput_16384, + throughput_65536, + throughput_262144, + throughput_1048576]}]. + +all_groups() -> + [{group, setup}, + {group, roundtrip}, + {group, throughput}]. + +init_per_suite(Config) -> + Digest = sha1, + ECCurve = secp521r1, + TLSVersion = 'tlsv1.2', + TLSCipher = {ecdhe_ecdsa,aes_128_cbc,sha256,sha256}, + %% + Node = node(), + try + Node =/= nonode@nohost orelse + throw({skipped,"Node not distributed"}), + {supported, SSLVersions} = + lists:keyfind(supported, 1, ssl:versions()), + lists:member(TLSVersion, SSLVersions) orelse + throw( + {skipped, + "SSL does not support " ++ term_to_string(TLSVersion)}), + lists:member(ECCurve, ssl:eccs(TLSVersion)) orelse + throw( + {skipped, + "SSL does not support " ++ term_to_string(ECCurve)}), + lists:member(TLSCipher, ssl:cipher_suites()) orelse + throw( + {skipped, + "SSL does not support " ++ term_to_string(TLSCipher)}) + of + _ -> + PrivDir = proplists:get_value(priv_dir, Config), + %% + [_, HostA] = string:split(atom_to_list(Node), "@"), + NodeAName = ?MODULE_STRING ++ "_node_a", + NodeAString = NodeAName ++ "@" ++ HostA, + NodeAConfFile = filename:join(PrivDir, NodeAString ++ ".conf"), + NodeA = list_to_atom(NodeAString), + %% + ServerNode = ssl_bench_test_lib:setup(dist_server), + [_, HostB] = string:split(atom_to_list(ServerNode), "@"), + NodeBName = ?MODULE_STRING ++ "_node_b", + NodeBString = NodeBName ++ "@" ++ HostB, + NodeBConfFile = filename:join(PrivDir, NodeBString ++ ".conf"), + NodeB = list_to_atom(NodeBString), + %% + CertOptions = + [{digest, Digest}, + {key, {namedCurve, ECCurve}}], + RootCert = + public_key:pkix_test_root_cert( + ?MODULE_STRING ++ " ROOT CA", CertOptions), + SSLConf = + [{verify, verify_peer}, + {versions, [TLSVersion]}, + {ciphers, [TLSCipher]}], + %% + write_node_conf( + NodeAConfFile, NodeA, + [{fail_if_no_peer_cert, true} | SSLConf], SSLConf, + CertOptions, RootCert), + write_node_conf( + NodeBConfFile, NodeB, + [{fail_if_no_peer_cert, true} | SSLConf], SSLConf, + CertOptions, RootCert), + %% + [{node_a_name, NodeAName}, + {node_a, NodeA}, + {node_a_dist_args, + "-proto_dist inet_tls " + "-ssl_dist_optfile " ++ NodeAConfFile ++ " "}, + {node_b_name, NodeBName}, + {node_b, NodeB}, + {node_b_dist_args, + "-proto_dist inet_tls " + "-ssl_dist_optfile " ++ NodeBConfFile ++ " "}, + {server_node, ServerNode} + |Config] + catch + throw:Result -> + Result + end. + +end_per_suite(Config) -> + ServerNode = proplists:get_value(server_node, Config), + slave:stop(ServerNode). + +init_per_group(ssl, Config) -> + [{ssl_dist, true}, {ssl_dist_prefix, "SSL"}|Config]; +init_per_group(plain, Config) -> + [{ssl_dist, false}, {ssl_dist_prefix, "Plain"}|Config]; +init_per_group(_GroupName, Config) -> + Config. + +end_per_group(_GroupName, _Config) -> + ok. + +init_per_testcase(_Func, Conf) -> + Conf. + +end_per_testcase(_Func, _Conf) -> + ok. + +-define(COUNT, 400). + +%%%------------------------------------------------------------------- +%%% CommonTest API helpers + +write_node_conf( + ConfFile, Node, ServerConf, ClientConf, CertOptions, RootCert) -> + Conf = + public_key:pkix_test_data( + #{root => RootCert, + peer => + [{extensions, + [#'Extension'{ + extnID = ?'id-ce-subjectAltName', + extnValue = [{dNSName, atom_to_list(Node)}], + critical = false}]} | CertOptions]}), + NodeConf = + [{server, ServerConf ++ Conf}, {client, ClientConf ++ Conf}], + {ok, Fd} = file:open(ConfFile, [write]), + ok = file:change_mode(ConfFile, 8#400), + io:format(Fd, "~p.~n", [NodeConf]), + ok = file:close(Fd). + + +%%%------------------------------------------------------------------- +%%% Test cases + +%%----------------------- +%% Connection setup speed + +setup(Config) -> + run_nodepair_test(fun setup/5, Config). + +setup(A, B, Prefix, HA, HB) -> + Rounds = 10, + [] = ssl_apply(HA, erlang, nodes, []), + [] = ssl_apply(HB, erlang, nodes, []), + {SetupTime, CycleTime} = + ssl_apply(HA, fun () -> setup_runner(A, B, Rounds) end), + [] = ssl_apply(HA, erlang, nodes, []), + [] = ssl_apply(HB, erlang, nodes, []), + SetupSpeed = round((Rounds*1000000*1000) / SetupTime), + CycleSpeed = round((Rounds*1000000*1000) / CycleTime), + _ = report(Prefix++" Setup", SetupSpeed, "setups/1000s"), + report(Prefix++" Setup Cycle", CycleSpeed, "cycles/1000s"). + +%% Runs on node A against rex in node B +setup_runner(A, B, Rounds) -> + StartTime = start_time(), + SetupTime = setup_loop(A, B, 0, Rounds), + {microseconds(SetupTime), microseconds(elapsed_time(StartTime))}. + +setup_loop(_A, _B, T, 0) -> + T; +setup_loop(A, B, T, N) -> + StartTime = start_time(), + [A] = rpc:block_call(B, erlang, nodes, []), + Time = elapsed_time(StartTime), + [B] = erlang:nodes(), + Mref = erlang:monitor(process, {rex,B}), + true = net_kernel:disconnect(B), + receive + {'DOWN',Mref,process,_,_} -> + [] = erlang:nodes(), + setup_loop(A, B, Time + T, N - 1) + end. + + +%%---------------- +%% Roundtrip speed + +roundtrip(Config) -> + run_nodepair_test(fun roundtrip/5, Config). + +roundtrip(A, B, Prefix, HA, HB) -> + Rounds = 40000, + [] = ssl_apply(HA, erlang, nodes, []), + [] = ssl_apply(HB, erlang, nodes, []), + Time = ssl_apply(HA, fun () -> roundtrip_runner(A, B, Rounds) end), + [B] = ssl_apply(HA, erlang, nodes, []), + [A] = ssl_apply(HB, erlang, nodes, []), + Speed = round((Rounds*1000000) / Time), + report(Prefix++" Roundtrip", Speed, "pings/s"). + +%% Runs on node A and spawns a server on node B +roundtrip_runner(A, B, Rounds) -> + ClientPid = self(), + [A] = rpc:call(B, erlang, nodes, []), + ServerPid = + erlang:spawn( + B, + fun () -> roundtrip_server(ClientPid, Rounds) end), + ServerMon = erlang:monitor(process, ServerPid), + microseconds( + roundtrip_client(ServerPid, ServerMon, start_time(), Rounds)). + +roundtrip_server(_Pid, 0) -> + ok; +roundtrip_server(Pid, N) -> + receive + N -> + Pid ! N, + roundtrip_server(Pid, N-1) + end. + +roundtrip_client(_Pid, Mon, StartTime, 0) -> + Time = elapsed_time(StartTime), + receive + {'DOWN', Mon, _, _, normal} -> + Time; + {'DOWN', Mon, _, _, Other} -> + exit(Other) + end; +roundtrip_client(Pid, Mon, StartTime, N) -> + Pid ! N, + receive + N -> + roundtrip_client(Pid, Mon, StartTime, N - 1) + end. + + +%%----------------- +%% Throughput speed + +throughput_1024(Config) -> + run_nodepair_test( + fun (A, B, Prefix, HA, HB) -> + throughput(A, B, Prefix, HA, HB, 100000, 1024) + end, Config). + +throughput_4096(Config) -> + run_nodepair_test( + fun (A, B, Prefix, HA, HB) -> + throughput(A, B, Prefix, HA, HB, 50000, 4096) + end, Config). + +throughput_16384(Config) -> + run_nodepair_test( + fun (A, B, Prefix, HA, HB) -> + throughput(A, B, Prefix, HA, HB, 10000, 16384) + end, Config). + +throughput_65536(Config) -> + run_nodepair_test( + fun (A, B, Prefix, HA, HB) -> + throughput(A, B, Prefix, HA, HB, 2000, 65536) + end, Config). + +throughput_262144(Config) -> + run_nodepair_test( + fun (A, B, Prefix, HA, HB) -> + throughput(A, B, Prefix, HA, HB, 500, 262144) + end, Config). + +throughput_1048576(Config) -> + run_nodepair_test( + fun (A, B, Prefix, HA, HB) -> + throughput(A, B, Prefix, HA, HB, 200, 1048576) + end, Config). + +throughput(A, B, Prefix, HA, HB, Packets, Size) -> + [] = ssl_apply(HA, erlang, nodes, []), + [] = ssl_apply(HB, erlang, nodes, []), + Time = + ssl_apply(HA, fun () -> throughput_runner(A, B, Packets, Size) end), + [B] = ssl_apply(HA, erlang, nodes, []), + [A] = ssl_apply(HB, erlang, nodes, []), + Speed = round((Packets*Size*1000000) / (1024*Time)), + report(Prefix++" Throughput_"++integer_to_list(Size), Speed, "kB/s"). + +%% Runs on node A and spawns a server on node B +throughput_runner(A, B, Rounds, Size) -> + Payload = payload(Size), + ClientPid = self(), + [A] = rpc:call(B, erlang, nodes, []), + ServerPid = + erlang:spawn( + B, + fun () -> throughput_server(ClientPid, Rounds) end), + ServerMon = erlang:monitor(process, ServerPid), + microseconds( + throughput_client( + ServerPid, ServerMon, Payload, start_time(), Rounds)). + +throughput_server(_Pid, 0) -> + ok; +throughput_server(Pid, N) -> + receive + [N|_] -> + throughput_server(Pid, N-1) + end. + +throughput_client(_Pid, Mon, _Payload, StartTime, 0) -> + receive + {'DOWN', Mon, _, _, normal} -> + elapsed_time(StartTime); + {'DOWN', Mon, _, _, Other} -> + exit(Other) + end; +throughput_client(Pid, Mon, Payload, StartTime, N) -> + Pid ! [N|Payload], + throughput_client(Pid, Mon, Payload, StartTime, N - 1). + +%%%------------------------------------------------------------------- +%%% Test cases helpers + +run_nodepair_test(TestFun, Config) -> + A = proplists:get_value(node_a, Config), + B = proplists:get_value(node_b, Config), + Prefix = proplists:get_value(ssl_dist_prefix, Config), + HA = start_ssl_node_a(Config), + HB = start_ssl_node_b(Config), + try TestFun(A, B, Prefix, HA, HB) + after + stop_ssl_node_a(HA), + stop_ssl_node_b(HB, Config), + ok + end. + +ssl_apply(Handle, M, F, Args) -> + case ssl_dist_test_lib:apply_on_ssl_node(Handle, M, F, Args) of + {'EXIT',Reason} -> + error(Reason); + Result -> + Result + end. + +ssl_apply(Handle, Fun) -> + case ssl_dist_test_lib:apply_on_ssl_node(Handle, Fun) of + {'EXIT',Reason} -> + error(Reason); + Result -> + Result + end. + +start_ssl_node_a(Config) -> + Name = proplists:get_value(node_a_name, Config), + Args = get_node_args(node_a_dist_args, Config), + ssl_dist_test_lib:start_ssl_node(Name, Args). + +start_ssl_node_b(Config) -> + Name = proplists:get_value(node_b_name, Config), + Args = get_node_args(node_b_dist_args, Config), + ServerNode = proplists:get_value(server_node, Config), + rpc:call( + ServerNode, ssl_dist_test_lib, start_ssl_node, [Name, Args]). + +stop_ssl_node_a(HA) -> + ssl_dist_test_lib:stop_ssl_node(HA). + +stop_ssl_node_b(HB, Config) -> + ServerNode = proplists:get_value(server_node, Config), + rpc:call(ServerNode, ssl_dist_test_lib, stop_ssl_node, [HB]). + +get_node_args(Tag, Config) -> + case proplists:get_value(ssl_dist, Config) of + true -> + proplists:get_value(Tag, Config); + false -> + "" + end. + + + +payload(Size) -> + iolist_to_binary( + [case Size bsr 8 of + 0 -> + []; + Blocks -> + payload(Blocks, create_binary(256)) + end | create_binary(Size band 255)]). +%% +payload(0, _) -> + []; +payload(Blocks, Block) -> + Half = payload(Blocks bsr 1, Block), + [Half, Half | + if + Blocks band 1 =:= 1 -> + Block; + true -> + [] + end]. + +create_binary(Size) -> + create_binary(Size, <<>>). +%% +create_binary(0, Bin) -> + Bin; +create_binary(Size, Bin) -> + NextSize = Size - 1, + create_binary(NextSize, <<Bin/binary, NextSize>>). + +start_time() -> + erlang:system_time(). + +elapsed_time(StartTime) -> + erlang:system_time() - StartTime. + +microseconds(Time) -> + erlang:convert_time_unit(Time, native, microsecond). + +report(Name, Value, Unit) -> + ct:pal("~s: ~w ~s", [Name, Value, Unit]), + ct_event:notify( + #event{ + name = benchmark_data, + data = [{value, Value}, {suite, "ssl_dist"}, {name, Name}]}), + {comment, term_to_string(Value) ++ " " ++ Unit}. + +term_to_string(Term) -> + unicode:characters_to_list( + io_lib:write(Term, [{encoding, unicode}])). diff --git a/lib/ssl/test/ssl_dist_test_lib.erl b/lib/ssl/test/ssl_dist_test_lib.erl new file mode 100644 index 0000000000..1b9c853fc4 --- /dev/null +++ b/lib/ssl/test/ssl_dist_test_lib.erl @@ -0,0 +1,343 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. 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(ssl_dist_test_lib). + +-include_lib("common_test/include/ct.hrl"). +-include_lib("public_key/include/public_key.hrl"). +-include("ssl_dist_test_lib.hrl"). + +-export([tstsrvr_format/2, send_to_tstcntrl/1]). +-export([apply_on_ssl_node/4, apply_on_ssl_node/2]). +-export([stop_ssl_node/1, start_ssl_node/2]). +%% +-export([cnct2tstsrvr/1]). + +-define(AWAIT_SSL_NODE_UP_TIMEOUT, 30000). + + + +%% ssl_node side api +%% + +tstsrvr_format(Fmt, ArgList) -> + send_to_tstsrvr({format, Fmt, ArgList}). + +send_to_tstcntrl(Message) -> + send_to_tstsrvr({message, Message}). + + +%% +%% test_server side api +%% + +apply_on_ssl_node( + #node_handle{connection_handler = Hndlr} = Node, + M, F, A) when is_atom(M), is_atom(F), is_list(A) -> + Ref = erlang:monitor(process, Hndlr), + apply_on_ssl_node(Node, Ref, {apply, self(), Ref, M, F, A}). + +apply_on_ssl_node( + #node_handle{connection_handler = Hndlr} = Node, + Fun) when is_function(Fun, 0) -> + Ref = erlang:monitor(process, Hndlr), + apply_on_ssl_node(Node, Ref, {apply, self(), Ref, Fun}). + +apply_on_ssl_node(Node, Ref, Msg) -> + send_to_ssl_node(Node, Msg), + receive + {'DOWN', Ref, process, Hndlr, Reason} -> + exit({handler_died, Hndlr, Reason}); + {Ref, Result} -> + Result + end. + +stop_ssl_node(#node_handle{connection_handler = Handler, + socket = Socket, + name = Name}) -> + ?t:format("Trying to stop ssl node ~s.~n", [Name]), + Mon = erlang:monitor(process, Handler), + unlink(Handler), + case gen_tcp:send(Socket, term_to_binary(stop)) of + ok -> + receive + {'DOWN', Mon, process, Handler, Reason} -> + case Reason of + normal -> + ok; + _ -> + ct:pal( + "stop_ssl_node/1 ~s Down ~p ~n", + [Name,Reason]) + end + end; + Error -> + erlang:demonitor(Mon, [flush]), + ct:pal("stop_ssl_node/1 ~s Warning ~p ~n", [Name,Error]) + end. + +start_ssl_node(Name, Args) -> + {ok, LSock} = gen_tcp:listen(0, + [binary, {packet, 4}, {active, false}]), + {ok, ListenPort} = inet:port(LSock), + CmdLine = mk_node_cmdline(ListenPort, Name, Args), + ?t:format("Attempting to start ssl node ~ts: ~ts~n", [Name, CmdLine]), + case open_port({spawn, CmdLine}, []) of + Port when is_port(Port) -> + unlink(Port), + erlang:port_close(Port), + case await_ssl_node_up(Name, LSock) of + #node_handle{} = NodeHandle -> + ?t:format("Ssl node ~s started.~n", [Name]), + NodeName = list_to_atom(Name ++ "@" ++ host_name()), + NodeHandle#node_handle{nodename = NodeName}; + Error -> + exit({failed_to_start_node, Name, Error}) + end; + Error -> + exit({failed_to_start_node, Name, Error}) + end. + +host_name() -> + [_, Host] = string:split(atom_to_list(node()), "@"), + %% [$@ | Host] = lists:dropwhile(fun ($@) -> false; (_) -> true end, + %% atom_to_list(node())), + Host. + +mk_node_cmdline(ListenPort, Name, Args) -> + Static = "-detached -noinput", + Pa = filename:dirname(code:which(?MODULE)), + Prog = case catch init:get_argument(progname) of + {ok,[[P]]} -> P; + _ -> exit(no_progname_argument_found) + end, + NameSw = case net_kernel:longnames() of + false -> "-sname "; + _ -> "-name " + end, + {ok, Pwd} = file:get_cwd(), + "\"" ++ Prog ++ "\" " + ++ Static ++ " " + ++ NameSw ++ " " ++ Name ++ " " + ++ "-pa " ++ Pa ++ " " + ++ "-run application start crypto -run application start public_key " + ++ "-eval 'net_kernel:verbose(1)' " + ++ "-run " ++ atom_to_list(?MODULE) ++ " cnct2tstsrvr " + ++ host_name() ++ " " + ++ integer_to_list(ListenPort) ++ " " + ++ Args ++ " " + ++ "-env ERL_CRASH_DUMP " ++ Pwd ++ "/erl_crash_dump." ++ Name ++ " " + ++ "-kernel error_logger \"{file,\\\"" ++ Pwd ++ "/error_log." ++ Name ++ "\\\"}\" " + ++ "-setcookie " ++ atom_to_list(erlang:get_cookie()). + +%% +%% Connection handler test_server side +%% + +await_ssl_node_up(Name, LSock) -> + case gen_tcp:accept(LSock, ?AWAIT_SSL_NODE_UP_TIMEOUT) of + {ok, Socket} -> + gen_tcp:close(LSock), + case gen_tcp:recv(Socket, 0) of + {ok, Bin} -> + check_ssl_node_up(Socket, Name, Bin); + {error, closed} -> + gen_tcp:close(Socket), + exit({lost_connection_with_ssl_node_before_up, Name}) + end; + {error, Error} -> + gen_tcp:close(LSock), + ?t:format("Accept failed for ssl node ~s: ~p~n", [Name,Error]), + exit({accept_failed, Error}) + end. + +check_ssl_node_up(Socket, Name, Bin) -> + case catch binary_to_term(Bin) of + {'EXIT', _} -> + gen_tcp:close(Socket), + exit({bad_data_received_from_ssl_node, Name, Bin}); + {ssl_node_up, NodeName} -> + case list_to_atom(Name++"@"++host_name()) of + NodeName -> + Parent = self(), + Go = make_ref(), + %% Spawn connection handler on test server side + Pid = spawn_link( + fun () -> + receive Go -> ok end, + process_flag(trap_exit, true), + tstsrvr_con_loop(Name, Socket, Parent) + end), + ok = gen_tcp:controlling_process(Socket, Pid), + Pid ! Go, + #node_handle{connection_handler = Pid, + socket = Socket, + name = Name}; + _ -> + exit({unexpected_ssl_node_connected, NodeName}) + end; + Msg -> + exit({unexpected_msg_instead_of_ssl_node_up, Name, Msg}) + end. + +send_to_ssl_node(#node_handle{connection_handler = Hndlr}, Term) -> + Hndlr ! {relay_to_ssl_node, term_to_binary(Term)}, + ok. + +tstsrvr_con_loop(Name, Socket, Parent) -> + ok = inet:setopts(Socket,[{active,once}]), + receive + {relay_to_ssl_node, Data} when is_binary(Data) -> + case gen_tcp:send(Socket, Data) of + ok -> + ok; + _Error -> + gen_tcp:close(Socket), + exit({failed_to_relay_data_to_ssl_node, Name, Data}) + end; + {tcp, Socket, Bin} -> + try binary_to_term(Bin) of + {format, FmtStr, ArgList} -> + ?t:format(FmtStr, ArgList); + {message, Msg} -> + ?t:format("Got message ~p", [Msg]), + Parent ! Msg; + {apply_res, To, Ref, Res} -> + To ! {Ref, Res}; + bye -> + {error, closed} = gen_tcp:recv(Socket, 0), + ?t:format("Ssl node ~s stopped.~n", [Name]), + gen_tcp:close(Socket), + exit(normal); + Unknown -> + exit({unexpected_message_from_ssl_node, Name, Unknown}) + catch + error : _ -> + gen_tcp:close(Socket), + exit({bad_data_received_from_ssl_node, Name, Bin}) + end; + {tcp_closed, Socket} -> + gen_tcp:close(Socket), + exit({lost_connection_with_ssl_node, Name}); + {'EXIT', Parent, Reason} -> + exit({'EXIT', parent, Reason}); + Unknown -> + exit({unknown, Unknown}) + end, + tstsrvr_con_loop(Name, Socket, Parent). + +%% +%% Connection handler ssl_node side +%% + +% cnct2tstsrvr() is called via command line arg -run ... +cnct2tstsrvr([Host, Port]) when is_list(Host), is_list(Port) -> + %% Spawn connection handler on ssl node side + ConnHandler + = spawn(fun () -> + case catch gen_tcp:connect(Host, + list_to_integer(Port), + [binary, + {packet, 4}, + {active, false}]) of + {ok, Socket} -> + notify_ssl_node_up(Socket), + ets:new(test_server_info, + [set, + public, + named_table, + {keypos, 1}]), + ets:insert(test_server_info, + {test_server_handler, self()}), + ssl_node_con_loop(Socket); + Error -> + halt("Failed to connect to test server " ++ + lists:flatten(io_lib:format("Host:~p ~n Port:~p~n Error:~p~n", + [Host, Port, Error]))) + end + end), + spawn(fun () -> + Mon = erlang:monitor(process, ConnHandler), + receive + {'DOWN', Mon, process, ConnHandler, Reason} -> + receive after 1000 -> ok end, + halt("test server connection handler terminated: " ++ + lists:flatten(io_lib:format("~p", [Reason]))) + end + end). + +notify_ssl_node_up(Socket) -> + case catch gen_tcp:send(Socket, + term_to_binary({ssl_node_up, node()})) of + ok -> ok; + _ -> halt("Failed to notify test server that I'm up") + end. + +send_to_tstsrvr(Term) -> + case catch ets:lookup_element(test_server_info, test_server_handler, 2) of + Hndlr when is_pid(Hndlr) -> + Hndlr ! {relay_to_test_server, term_to_binary(Term)}, ok; + _ -> + receive after 200 -> ok end, + send_to_tstsrvr(Term) + end. + +ssl_node_con_loop(Socket) -> + inet:setopts(Socket,[{active,once}]), + receive + {relay_to_test_server, Data} when is_binary(Data) -> + case gen_tcp:send(Socket, Data) of + ok -> + ok; + _Error -> + gen_tcp:close(Socket), + halt("Failed to relay data to test server") + end; + {tcp, Socket, Bin} -> + case catch binary_to_term(Bin) of + {'EXIT', _} -> + gen_tcp:close(Socket), + halt("test server sent me bad data"); + {apply, From, Ref, M, F, A} -> + spawn_link( + fun () -> + send_to_tstsrvr({apply_res, + From, + Ref, + (catch apply(M, F, A))}) + end); + {apply, From, Ref, Fun} -> + spawn_link(fun () -> + send_to_tstsrvr({apply_res, + From, + Ref, + (catch Fun())}) + end); + stop -> + gen_tcp:send(Socket, term_to_binary(bye)), + init:stop(), + receive after infinity -> ok end; + _Unknown -> + halt("test server sent me an unexpected message") + end; + {tcp_closed, Socket} -> + halt("Lost connection to test server") + end, + ssl_node_con_loop(Socket). diff --git a/lib/ssl/test/ssl_dist_test_lib.hrl b/lib/ssl/test/ssl_dist_test_lib.hrl new file mode 100644 index 0000000000..86b9b37026 --- /dev/null +++ b/lib/ssl/test/ssl_dist_test_lib.hrl @@ -0,0 +1,26 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. 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% +%% + +-record(node_handle, + {connection_handler, + socket, + name, + nodename} + ). diff --git a/lib/ssl/test/ssl_engine_SUITE.erl b/lib/ssl/test/ssl_engine_SUITE.erl new file mode 100644 index 0000000000..bc221d35fd --- /dev/null +++ b/lib/ssl/test/ssl_engine_SUITE.erl @@ -0,0 +1,142 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017-2017. 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(ssl_engine_SUITE). + +%% Note: This directive should only be used in test suites. +-compile(export_all). + +-include_lib("common_test/include/ct.hrl"). +-include_lib("public_key/include/public_key.hrl"). + +%%-------------------------------------------------------------------- +%% Common Test interface functions ----------------------------------- +%%-------------------------------------------------------------------- +all() -> + [ + private_key + ]. + +init_per_suite(Config) -> + catch crypto:stop(), + try crypto:start() of + ok -> + ssl_test_lib:clean_start(), + case crypto:get_test_engine() of + {ok, EngineName} -> + try crypto:engine_load(<<"dynamic">>, + [{<<"SO_PATH">>, EngineName}, + <<"LOAD">>], + []) of + {ok, Engine} -> + [{engine, Engine} |Config]; + {error, Reason} -> + ct:pal("Reason ~p", [Reason]), + {skip, "No dynamic engine support"} + catch error:notsup -> + {skip, "No engine support in OpenSSL"} + end; + {error, notexist} -> + {skip, "Test engine not found"} + end + catch _:_ -> + {skip, "Crypto did not start"} + end. + +end_per_suite(Config) -> + Engine = proplists:get_value(engine, Config), + crypto:engine_unload(Engine), + ssl:stop(), + application:stop(crypto). + + +init_per_testcase(_TestCase, Config) -> + ssl:stop(), + ssl:start(), + ssl_test_lib:ct_log_supported_protocol_versions(Config), + ct:timetrap({seconds, 10}), + Config. + +end_per_testcase(_TestCase, Config) -> + Config. + +%%-------------------------------------------------------------------- +%% Test Cases -------------------------------------------------------- +%%-------------------------------------------------------------------- + +private_key(Config) when is_list(Config) -> + ClientFileBase = filename:join([proplists:get_value(priv_dir, Config), "client_engine"]), + ServerFileBase = filename:join([proplists:get_value(priv_dir, Config), "server_engine"]), + #{server_config := ServerConf, + client_config := ClientConf} = GenCertData = + public_key:pkix_test_data(#{server_chain => + #{root => [{key, ssl_test_lib:hardcode_rsa_key(1)}], + intermediates => [[{key, ssl_test_lib:hardcode_rsa_key(2)}]], + peer => [{key, ssl_test_lib:hardcode_rsa_key(3)} + ]}, + client_chain => + #{root => [{key, ssl_test_lib:hardcode_rsa_key(4)}], + intermediates => [[{key, ssl_test_lib:hardcode_rsa_key(5)}]], + peer => [{key, ssl_test_lib:hardcode_rsa_key(6)}]}}), + [{server_config, FileServerConf}, + {client_config, FileClientConf}] = + x509_test:gen_pem_config_files(GenCertData, ClientFileBase, ServerFileBase), + + Engine = proplists:get_value(engine, Config), + + ClientKey = engine_key(FileClientConf), + ServerKey = engine_key(FileServerConf), + + EngineClientConf = [{key, #{algorithm => rsa, + engine => Engine, + key_id => ClientKey}} | proplists:delete(key, ClientConf)], + + EngineServerConf = [{key, #{algorithm => rsa, + engine => Engine, + key_id => ServerKey}} | proplists:delete(key, ServerConf)], + %% Test with engine + test_tls_connection(EngineServerConf, EngineClientConf, Config), + %% Test that sofware fallback is available + test_tls_connection(ServerConf, [{reuse_sessions, false} |ClientConf], Config). + +engine_key(Conf) -> + FileStr = proplists:get_value(keyfile, Conf), + list_to_binary(FileStr). + + +test_tls_connection(ServerConf, ClientConf, Config) -> + {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), + + Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, + {from, self()}, + {mfa, {ssl_test_lib, send_recv_result_active, []}}, + {options, [{verify, verify_peer} + | ServerConf]}]), + Port = ssl_test_lib:inet_port(Server), + Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, + {host, Hostname}, + {from, self()}, + {mfa, {ssl_test_lib, send_recv_result_active, []}}, + {options, [{verify, verify_peer} | ClientConf]}]), + + ssl_test_lib:check_result(Server, ok, Client, ok), + ssl_test_lib:close(Server), + ssl_test_lib:close(Client). diff --git a/lib/ssl/test/ssl_test_lib.erl b/lib/ssl/test/ssl_test_lib.erl index 4e7252f469..7e983f5079 100644 --- a/lib/ssl/test/ssl_test_lib.erl +++ b/lib/ssl/test/ssl_test_lib.erl @@ -1024,49 +1024,70 @@ string_regex_filter(Str, Search) when is_list(Str) -> string_regex_filter(_Str, _Search) -> false. -anonymous_suites(Version) -> - Suites = [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:anonymous_suites(Version)], - ssl_cipher:filter_suites(Suites). - -psk_suites(Version) -> - Suites = [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:psk_suites(Version)], - ssl_cipher:filter_suites(Suites). - -psk_anon_suites(Version) -> - Suites = [Suite || Suite <- psk_suites(Version), is_psk_anon_suite(Suite)], - ssl_cipher:filter_suites(Suites). - +anonymous_suites({3,_ } = Version) -> + [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:anonymous_suites(Version))]; +anonymous_suites(DTLSVersion) -> + Version = dtls_v1:corresponding_tls_version(DTLSVersion), + [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:anonymous_suites(Version)), + not ssl_cipher:is_stream_ciphersuite(tuple_to_map(ssl_cipher:erl_suite_definition(S)))]. + +psk_suites({3,_ } = Version) -> + [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:psk_suites(Version))]; +psk_suites(DTLSVersion) -> + Version = dtls_v1:corresponding_tls_version(DTLSVersion), + [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:psk_suites(Version)), + not ssl_cipher:is_stream_ciphersuite(tuple_to_map(ssl_cipher:erl_suite_definition(S)))]. + +psk_anon_suites({3,_ } = Version) -> + [Suite || Suite <- psk_suites(Version), is_psk_anon_suite(Suite)]; +psk_anon_suites(DTLSVersion) -> + Version = dtls_v1:corresponding_tls_version(DTLSVersion), + [Suite || Suite <- psk_suites(Version), is_psk_anon_suite(Suite), + not ssl_cipher:is_stream_ciphersuite(tuple_to_map(Suite))]. srp_suites() -> - Suites = - [{srp_anon, '3des_ede_cbc', sha}, - {srp_rsa, '3des_ede_cbc', sha}, - {srp_anon, aes_128_cbc, sha}, - {srp_rsa, aes_128_cbc, sha}, - {srp_anon, aes_256_cbc, sha}, - {srp_rsa, aes_256_cbc, sha}], - ssl_cipher:filter_suites(Suites). - + [ssl_cipher:erl_suite_definition(Suite) || + Suite <- + ssl_cipher:filter_suites([tuple_to_map(S) || + S <- [{srp_anon,'3des_ede_cbc', sha}, + {srp_rsa, '3des_ede_cbc', sha}, + {srp_anon, aes_128_cbc, sha}, + {srp_rsa, aes_128_cbc, sha}, + {srp_anon, aes_256_cbc, sha}, + {srp_rsa, aes_256_cbc, sha}]])]. srp_anon_suites() -> - Suites = - [{srp_anon, '3des_ede_cbc', sha}, - {srp_anon, aes_128_cbc, sha}, - {srp_anon, aes_256_cbc, sha}], - ssl_cipher:filter_suites(Suites). - + [ssl_cipher:erl_suite_definition(Suite) || + Suite <- + ssl_cipher:filter_suites([tuple_to_map(S) || + S <-[{srp_anon, '3des_ede_cbc', sha}, + {srp_anon, aes_128_cbc, sha}, + {srp_anon, aes_256_cbc, sha}]])]. srp_dss_suites() -> - Suites = - [{srp_dss, '3des_ede_cbc', sha}, - {srp_dss, aes_128_cbc, sha}, - {srp_dss, aes_256_cbc, sha}], - ssl_cipher:filter_suites(Suites). + [ssl_cipher:erl_suite_definition(Suite) || + Suite <- + ssl_cipher:filter_suites([tuple_to_map(S) || + S <- [{srp_dss, '3des_ede_cbc', sha}, + {srp_dss, aes_128_cbc, sha}, + {srp_dss, aes_256_cbc, sha}]])]. + +chacha_suites(Version) -> + [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:chacha_suites(Version))]. rc4_suites(Version) -> - Suites = [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:rc4_suites(Version)], - ssl_cipher:filter_suites(Suites). + [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:rc4_suites(Version))]. des_suites(Version) -> - Suites = ssl_cipher:des_suites(Version), - ssl_cipher:filter_suites(Suites). + [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:des_suites(Version))]. + +tuple_to_map({Kex, Cipher, Mac}) -> + #{key_exchange => Kex, + cipher => Cipher, + mac => Mac, + prf => default_prf}; +tuple_to_map({Kex, Cipher, Mac, Prf}) -> + #{key_exchange => Kex, + cipher => Cipher, + mac => Mac, + prf => Prf}. pem_to_der(File) -> {ok, PemBin} = file:read_file(File), @@ -1292,6 +1313,32 @@ cipher_restriction(Config0) -> Config0 end. +openssl_dsa_support() -> + case os:cmd("openssl version") of + "LibreSSL 2.6.1" ++ _ -> + true; + "LibreSSL 2.6.2" ++ _ -> + true; + "LibreSSL 2.6" ++ _ -> + false; + "LibreSSL 2.4" ++ _ -> + true; + "LibreSSL 2.3" ++ _ -> + true; + "LibreSSL 2.2" ++ _ -> + true; + "LibreSSL 2.1" ++ _ -> + true; + "LibreSSL 2.0" ++ _ -> + true; + "LibreSSL" ++ _ -> + false; + "OpenSSL 1.0.1" ++ Rest -> + hd(Rest) >= s; + _ -> + true + end. + check_sane_openssl_version(Version) -> case supports_ssl_tls_version(Version) of true -> @@ -1329,8 +1376,9 @@ enough_openssl_crl_support(_) -> true. wait_for_openssl_server(Port, tls) -> do_wait_for_openssl_tls_server(Port, 10); -wait_for_openssl_server(Port, dtls) -> - do_wait_for_openssl_dtls_server(Port, 10). +wait_for_openssl_server(_Port, dtls) -> + ok. %% No need to wait for DTLS over UDP server + %% client will retransmitt until it is up. do_wait_for_openssl_tls_server(_, 0) -> exit(failed_to_connect_to_openssl); @@ -1343,21 +1391,6 @@ do_wait_for_openssl_tls_server(Port, N) -> do_wait_for_openssl_tls_server(Port, N-1) end. -do_wait_for_openssl_dtls_server(_, 0) -> - %%exit(failed_to_connect_to_openssl); - ok; -do_wait_for_openssl_dtls_server(Port, N) -> - %% case gen_udp:open(0) of - %% {ok, S} -> - %% gen_udp:connect(S, "localhost", Port), - %% gen_udp:close(S); - %% _ -> - %% ct:sleep(?SLEEP), - %% do_wait_for_openssl_dtls_server(Port, N-1) - %% end. - ct:sleep(500), - do_wait_for_openssl_dtls_server(Port, N-1). - version_flag(tlsv1) -> "-tls1"; version_flag('tlsv1.1') -> @@ -1658,78 +1691,3 @@ hardcode_dsa_key(3) -> y = 48598545580251057979126570873881530215432219542526130654707948736559463436274835406081281466091739849794036308281564299754438126857606949027748889019480936572605967021944405048011118039171039273602705998112739400664375208228641666852589396502386172780433510070337359132965412405544709871654840859752776060358, x = 1457508827177594730669011716588605181448418352823}. -dtls_hello() -> - [1, - <<0,1,4>>, - <<0,0>>, - <<0,0,0>>, - <<0,1,4>>, - <<254,253,88, - 156,129,61, - 131,216,15, - 131,194,242, - 46,154,190, - 20,228,234, - 234,150,44, - 62,96,96,103, - 127,95,103, - 23,24,42,138, - 13,142,32,57, - 230,177,32, - 210,154,152, - 188,121,134, - 136,53,105, - 118,96,106, - 103,231,223, - 133,10,165, - 50,32,211, - 227,193,14, - 181,143,48, - 66,0,0,100,0, - 255,192,44, - 192,48,192, - 36,192,40, - 192,46,192, - 50,192,38, - 192,42,0,159, - 0,163,0,107, - 0,106,0,157, - 0,61,192,43, - 192,47,192, - 35,192,39, - 192,45,192, - 49,192,37, - 192,41,0,158, - 0,162,0,103, - 0,64,0,156,0, - 60,192,10, - 192,20,0,57, - 0,56,192,5, - 192,15,0,53, - 192,8,192,18, - 0,22,0,19, - 192,3,192,13, - 0,10,192,9, - 192,19,0,51, - 0,50,192,4, - 192,14,0,47, - 1,0,0,86,0,0, - 0,14,0,12,0, - 0,9,108,111, - 99,97,108, - 104,111,115, - 116,0,10,0, - 58,0,56,0,14, - 0,13,0,25,0, - 28,0,11,0,12, - 0,27,0,24,0, - 9,0,10,0,26, - 0,22,0,23,0, - 8,0,6,0,7,0, - 20,0,21,0,4, - 0,5,0,18,0, - 19,0,1,0,2,0, - 3,0,15,0,16, - 0,17,0,11,0, - 2,1,0>>]. - diff --git a/lib/ssl/test/ssl_to_openssl_SUITE.erl b/lib/ssl/test/ssl_to_openssl_SUITE.erl index 9118e4b7e3..f091c8786e 100644 --- a/lib/ssl/test/ssl_to_openssl_SUITE.erl +++ b/lib/ssl/test/ssl_to_openssl_SUITE.erl @@ -143,10 +143,15 @@ init_per_suite(Config0) -> try crypto:start() of ok -> ssl_test_lib:clean_start(), - - Config1 = ssl_test_lib:make_rsa_cert(Config0), - Config2 = ssl_test_lib:make_dsa_cert(Config1), - ssl_test_lib:cipher_restriction(Config2) + Config = + case ssl_test_lib:openssl_dsa_support() of + true -> + Config1 = ssl_test_lib:make_rsa_cert(Config0), + ssl_test_lib:make_dsa_cert(Config1); + false -> + ssl_test_lib:make_rsa_cert(Config0) + end, + ssl_test_lib:cipher_restriction(Config) catch _:_ -> {skip, "Crypto did not start"} end @@ -199,15 +204,27 @@ init_per_testcase(expired_session, Config) -> ssl:start(), Config; -init_per_testcase(TestCase, Config) when TestCase == ciphers_rsa_signed_certs; - TestCase == ciphers_dsa_signed_certs -> - ct:timetrap({seconds, 60}), - special_init(TestCase, Config); - +init_per_testcase(TestCase, Config) when + TestCase == ciphers_dsa_signed_certs; + TestCase == erlang_client_openssl_server_dsa_cert; + TestCase == erlang_server_openssl_client_dsa_cert; + TestCase == erlang_client_openssl_server_dsa_cert; + TestCase == erlang_server_openssl_client_dsa_cert -> + case ssl_test_lib:openssl_dsa_support() of + true -> + special_init(TestCase, Config); + false -> + {skip, "DSA not supported by OpenSSL"} + end; init_per_testcase(TestCase, Config) -> - ct:timetrap({seconds, 20}), + ct:timetrap({seconds, 35}), special_init(TestCase, Config). +special_init(TestCase, Config) when + TestCase == ciphers_rsa_signed_certs; + TestCase == ciphers_dsa_signed_certs-> + ct:timetrap({seconds, 90}), + Config; special_init(TestCase, Config) when TestCase == erlang_client_openssl_server_renegotiate; TestCase == erlang_client_openssl_server_nowrap_seqnum; @@ -1016,7 +1033,7 @@ ssl2_erlang_server_openssl_client(Config) when is_list(Config) -> ct:log("Ports ~p~n", [[erlang:port_info(P) || P <- erlang:ports()]]), consume_port_exit(OpenSslPort), - ssl_test_lib:check_result(Server, {error, {tls_alert, "handshake failure"}}), + ssl_test_lib:check_result(Server, {error, {tls_alert, "bad record mac"}}), process_flag(trap_exit, false). %%-------------------------------------------------------------------- ssl2_erlang_server_openssl_client_comp() -> diff --git a/lib/ssl/vsn.mk b/lib/ssl/vsn.mk index bb77326751..2650399eea 100644 --- a/lib/ssl/vsn.mk +++ b/lib/ssl/vsn.mk @@ -1 +1 @@ -SSL_VSN = 8.2.1 +SSL_VSN = 8.2.3 diff --git a/lib/stdlib/doc/src/Makefile b/lib/stdlib/doc/src/Makefile index 93eac8220d..af27efa6c1 100644 --- a/lib/stdlib/doc/src/Makefile +++ b/lib/stdlib/doc/src/Makefile @@ -98,13 +98,15 @@ XML_REF3_FILES = \ sys.xml \ timer.xml \ unicode.xml \ + uri_string.xml \ win32reg.xml \ zip.xml XML_REF6_FILES = stdlib_app.xml XML_PART_FILES = part.xml -XML_CHAPTER_FILES = io_protocol.xml unicode_usage.xml notes.xml notes_history.xml assert_hrl.xml +XML_CHAPTER_FILES = introduction.xml io_protocol.xml unicode_usage.xml \ + notes.xml assert_hrl.xml BOOK_FILES = book.xml diff --git a/lib/stdlib/doc/src/digraph.xml b/lib/stdlib/doc/src/digraph.xml index 5332d7aba5..db96beed6c 100644 --- a/lib/stdlib/doc/src/digraph.xml +++ b/lib/stdlib/doc/src/digraph.xml @@ -170,6 +170,10 @@ <p>If the edge would create a cycle in an <seealso marker="#acyclic_digraph">acyclic digraph</seealso>, <c>{error, {bad_edge, <anno>Path</anno>}}</c> is returned. + If <c><anno>G</anno></c> already has an edge with value + <c><anno>E</anno></c> connecting a different pair of vertices, + <c>{error, {bad_edge, [<anno>V1</anno>, <anno>V2</anno>]}}</c> + is returned. If either of <c><anno>V1</anno></c> or <c><anno>V2</anno></c> is not a vertex of digraph <c><anno>G</anno></c>, <c>{error, {bad_vertex, </c><anno>V</anno><c>}}</c> is diff --git a/lib/stdlib/doc/src/ets.xml b/lib/stdlib/doc/src/ets.xml index 576959b1c8..1b31a1ec9d 100644 --- a/lib/stdlib/doc/src/ets.xml +++ b/lib/stdlib/doc/src/ets.xml @@ -963,11 +963,11 @@ ets:is_compiled_ms(Broken).</code> <func> <name name="match_spec_run" arity="2"/> <fsummary>Perform matching, using a compiled match specification on a - list of tuples.</fsummary> + list of terms.</fsummary> <desc> <p>Executes the matching specified in a compiled <seealso marker="#match_spec">match specification</seealso> on a list - of tuples. Term <c><anno>CompiledMatchSpec</anno></c> is to be + of terms. Term <c><anno>CompiledMatchSpec</anno></c> is to be the result of a call to <seealso marker="#match_spec_compile/1"> <c>match_spec_compile/1</c></seealso> and is hence the internal representation of the match specification one wants to use.</p> @@ -985,7 +985,7 @@ Table = ets:new... MatchSpec = ... % The following call... ets:match_spec_run(ets:tab2list(Table), -ets:match_spec_compile(MatchSpec)), + ets:match_spec_compile(MatchSpec)), % ...gives the same result as the more common (and more efficient) ets:select(Table, MatchSpec),</code> <note> @@ -1961,7 +1961,7 @@ true</pre> The return value is a list of the new counter values from each update operation in the same order as in the operation list. If an empty list is specified, nothing is updated and an empty list is - returned. If the function fails, no updates is done.</p> + returned. If the function fails, no updates are done.</p> <p>The specified <c><anno>Key</anno></c> is used to identify the object by either <em>matching</em> the key of an object in a <c>set</c> table, or <em>compare equal</em> to the key of an object in an diff --git a/lib/stdlib/doc/src/filelib.xml b/lib/stdlib/doc/src/filelib.xml index 5e631aac21..3b5be75bc0 100644 --- a/lib/stdlib/doc/src/filelib.xml +++ b/lib/stdlib/doc/src/filelib.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>2003</year><year>2017</year> + <year>2003</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -296,7 +296,7 @@ filelib:wildcard("lib/**/*.{erl,hrl}")</code> for a file with the extension <c>.beam</c>, the default rule is to look for a file with a corresponding extension <c>.erl</c> by replacing the suffix <c>"ebin"</c> of the object directory path with - <c>"src"</c>. + <c>"src"</c> or <c>"src/*"</c>. The file search is done through <seealso marker="#find_file/3"><c>find_file/3</c></seealso>. The directory of the object file is always tried before any other directory specified diff --git a/lib/stdlib/doc/src/filename.xml b/lib/stdlib/doc/src/filename.xml index d2608ad542..ce19f70df0 100644 --- a/lib/stdlib/doc/src/filename.xml +++ b/lib/stdlib/doc/src/filename.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>1997</year><year>2017</year> + <year>1997</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -399,15 +399,18 @@ true tuples <c>{<anno>BinSuffix</anno>, <anno>SourceSuffix</anno>}</c> and is interpreted as follows: if the end of the directory name where the object is located matches <c><anno>BinSuffix</anno></c>, then the - source code directory has the same name, but with - <c><anno>BinSuffix</anno></c> replaced by - <c><anno>SourceSuffix</anno></c>. <c><anno>Rules</anno></c> defaults + name created by replacing <c><anno>BinSuffix</anno></c> with + <c><anno>SourceSuffix</anno></c> is expanded by calling + <seealso marker="filelib#wildcard/1"> + <c>filelib:wildcard/1</c></seealso>. + If a regular file is found among the matches, the function + returns that location together with <c><anno>Options</anno></c>. + Otherwise the next rule is tried, and so on.</p> + <p><c><anno>Rules</anno></c> defaults to:</p> <code type="none"> -[{"", ""}, {"ebin", "src"}, {"ebin", "esrc"}]</code> - <p>If the source file is found in the resulting directory, the function - returns that location together with <c><anno>Options</anno></c>. - Otherwise the next rule is tried, and so on.</p> +[{"", ""}, {"ebin", "src"}, {"ebin", "esrc"}, + {"ebin", "src/*"}, {"ebin", "esrc/*"}]</code> <p>The function returns <c>{<anno>SourceFile</anno>, <anno>Options</anno>}</c> if it succeeds. <c><anno>SourceFile</anno></c> is the absolute path to the source diff --git a/lib/stdlib/doc/src/gen_statem.xml b/lib/stdlib/doc/src/gen_statem.xml index 4a824f073e..be0d64feba 100644 --- a/lib/stdlib/doc/src/gen_statem.xml +++ b/lib/stdlib/doc/src/gen_statem.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>2016</year><year>2017</year> + <year>2016</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -543,7 +543,23 @@ handle_event(_, _, State, Data) -> <name name="event_type"/> <desc> <p> - External events are of three types: + There are 3 categories of events: + <seealso marker="#type-external_event_type">external</seealso>, + <seealso marker="#type-timeout_event_type">timeout</seealso>, + and <c>internal</c>. + </p> + <p> + <c>internal</c> events can only be generated by the + state machine itself through the state transition action + <seealso marker="#type-action"><c>next_event</c></seealso>. + </p> + </desc> + </datatype> + <datatype> + <name name="external_event_type"/> + <desc> + <p> + External events are of 3 types: <c>{call,<anno>From</anno>}</c>, <c>cast</c>, or <c>info</c>. <seealso marker="#call/2">Calls</seealso> (synchronous) and @@ -551,12 +567,17 @@ handle_event(_, _, State, Data) -> originate from the corresponding API functions. For calls, the event contains whom to reply to. Type <c>info</c> originates from regular process messages sent - to the <c>gen_statem</c>. The state machine - implementation can, in addition to the above, - generate - <seealso marker="#type-event_type"><c>events of types</c></seealso> - <c>timeout</c>, <c>{timeout,<anno>Name</anno>}</c>, - <c>state_timeout</c>, and <c>internal</c> to itself. + to the <c>gen_statem</c>. + </p> + </desc> + </datatype> + <datatype> + <name name="timeout_event_type"/> + <desc> + <p> + There are 3 types of timeout events that the state machine + can generate for itself with the corresponding + <seealso marker="#type-timeout_action">timeout_action()</seealso>s. </p> </desc> </datatype> @@ -1026,6 +1047,25 @@ handle_event(_, _, State, Data) -> for this state transition. </p> </item> + </taglist> + </desc> + </datatype> + <datatype> + <name name="timeout_action"/> + <desc> + <p> + These state transition actions can be invoked by + returning them from the + <seealso marker="#state callback">state callback</seealso>, from + <seealso marker="#Module:init/1"><c>Module:init/1</c></seealso> + or by giving them to + <seealso marker="#enter_loop/5"><c>enter_loop/5,6</c></seealso>. + </p> + <p> + These timeout actions sets timeout + <seealso marker="#type-transition_option">transition options</seealso>. + </p> + <taglist> <tag><c>Timeout</c></tag> <item> <p> diff --git a/lib/stdlib/doc/src/io.xml b/lib/stdlib/doc/src/io.xml index 64fcf4379f..72c774e6ef 100644 --- a/lib/stdlib/doc/src/io.xml +++ b/lib/stdlib/doc/src/io.xml @@ -257,8 +257,9 @@ ok</pre> \x{400} ok 5> <input>io:fwrite("~s~n",[[1024]]).</input> -** exception exit: {badarg,[{io,format,[<0.26.0>,"~s~n",[[1024]]]}, - ...</pre> +** exception error: bad argument + in function io:format/3 + called as io:format(<0.53.0>,"~s~n",[[1024]])</pre> </item> <tag><c>w</c></tag> <item> @@ -454,12 +455,9 @@ ok</pre> abc def 'abc def' {foo,1} A ok 2> <input>io:fwrite("~s", [65]).</input> -** exception exit: {badarg,[{io,format,[<0.22.0>,"~s","A"]}, - {erl_eval,do_apply,5}, - {shell,exprs,6}, - {shell,eval_exprs,6}, - {shell,eval_loop,3}]} - in function io:o_request/2</pre> +** exception error: bad argument + in function io:format/3 + called as io:format(<0.53.0>,"~s","A")</pre> <p>In this example, an attempt was made to output the single character 65 with the aid of the string formatting directive <c>"~s"</c>.</p> diff --git a/lib/stdlib/doc/src/maps.xml b/lib/stdlib/doc/src/maps.xml index 8c7270816b..987d92989d 100644 --- a/lib/stdlib/doc/src/maps.xml +++ b/lib/stdlib/doc/src/maps.xml @@ -33,16 +33,31 @@ <p>This module contains functions for maps processing.</p> </description> + <datatypes> + <datatype> + <name name="iterator"/> + <desc> + <p>An iterator representing the key value associations in a map.</p> + <p>Created using <seealso marker="#iterator-1"><c>maps:iterator/1</c></seealso>.</p> + <p>Consumed by <seealso marker="#next-1"><c>maps:next/1</c></seealso>, + <seealso marker="#filter-2"><c>maps:filter/2</c></seealso>, + <seealso marker="#fold-3"><c>maps:fold/3</c></seealso> and + <seealso marker="#map-2"><c>maps:map/2</c></seealso>.</p> + </desc> + </datatype> + </datatypes> + <funcs> <func> <name name="filter" arity="2"/> <fsummary>Select pairs that satisfy a predicate.</fsummary> <desc> - <p>Returns a map <c><anno>Map2</anno></c> for which predicate - <c><anno>Pred</anno></c> holds true in <c><anno>Map1</anno></c>.</p> + <p>Returns a map <c><anno>Map</anno></c> for which predicate + <c><anno>Pred</anno></c> holds true in <c><anno>MapOrIter</anno></c>.</p> <p>The call fails with a <c>{badmap,Map}</c> exception if - <c><anno>Map1</anno></c> is not a map, or with <c>badarg</c> if - <c><anno>Pred</anno></c> is not a function of arity 2.</p> + <c><anno>MapOrIter</anno></c> is not a map or valid iterator, + or with <c>badarg</c> if <c><anno>Pred</anno></c> is not a + function of arity 2.</p> <p><em>Example:</em></p> <code type="none"> > M = #{a => 2, b => 3, c=> 4, "a" => 1, "b" => 2, "c" => 4}, @@ -76,12 +91,16 @@ <fsummary></fsummary> <desc> <p>Calls <c>F(K, V, AccIn)</c> for every <c><anno>K</anno></c> to value - <c><anno>V</anno></c> association in <c><anno>Map</anno></c> in + <c><anno>V</anno></c> association in <c><anno>MapOrIter</anno></c> in any order. Function <c>fun F/3</c> must return a new accumulator, which is passed to the next successive call. This function returns the final value of the accumulator. The initial accumulator value <c><anno>Init</anno></c> is returned if the map is empty.</p> + <p>The call fails with a <c>{badmap,Map}</c> exception if + <c><anno>MapOrIter</anno></c> is not a map or valid iterator, + or with <c>badarg</c> if <c><anno>Fun</anno></c> is not a + function of arity 3.</p> <p><em>Example:</em></p> <code type="none"> > Fun = fun(K,V,AccIn) when is_list(K) -> AccIn + V end, @@ -169,6 +188,32 @@ false</code> </func> <func> + <name name="iterator" arity="1"/> + <fsummary>Create a map iterator.</fsummary> + <desc> + <p>Returns a map iterator <c><anno>Iterator</anno></c> that can + be used by <seealso marker="#next-1"><c>maps:next/1</c></seealso> + to traverse the key-value associations in a map. When iterating + over a map, the memory usage is guaranteed to be bounded no matter + the size of the map.</p> + <p>The call fails with a <c>{badmap,Map}</c> exception if + <c><anno>Map</anno></c> is not a map.</p> + <p><em>Example:</em></p> + <code type="none"> +> M = #{ a => 1, b => 2 }. +#{a => 1,b => 2} +> I = maps:iterator(M). +[{a,1},{b,2}] +> {K1, V1, I2} = maps:next(I). +{a,1,[{b,2}]} +> {K2, V2, I3} = maps:next(I2). +{b,2,[]} +> maps:next(I3). +none</code> + </desc> + </func> + + <func> <name name="keys" arity="1"/> <fsummary></fsummary> <desc> @@ -188,12 +233,16 @@ false</code> <name name="map" arity="2"/> <fsummary></fsummary> <desc> - <p>Produces a new map <c><anno>Map2</anno></c> by calling function + <p>Produces a new map <c><anno>Map</anno></c> by calling function <c>fun F(K, V1)</c> for every <c><anno>K</anno></c> to value - <c><anno>V1</anno></c> association in <c><anno>Map1</anno></c> in + <c><anno>V1</anno></c> association in <c><anno>MapOrIter</anno></c> in any order. Function <c>fun F/2</c> must return value <c><anno>V2</anno></c> to be associated with key <c><anno>K</anno></c> - for the new map <c><anno>Map2</anno></c>.</p> + for the new map <c><anno>Map</anno></c>.</p> + <p>The call fails with a <c>{badmap,Map}</c> exception if + <c><anno>MapOrIter</anno></c> is not a map or valid iterator, + or with <c>badarg</c> if <c><anno>Fun</anno></c> is not a + function of arity 2.</p> <p><em>Example:</em></p> <code type="none"> > Fun = fun(K,V1) when is_list(K) -> V1*2 end, @@ -234,6 +283,35 @@ false</code> </func> <func> + <name name="next" arity="1"/> + <fsummary>Get the next key and value from an iterator.</fsummary> + <desc> + <p>Returns the next key-value association in + <c><anno>Iterator</anno></c> and a new iterator for the + remaining associations in the iterator. + </p> + <p> + If there are no more associations in the iterator, + <c>none</c> is returned. + </p> + <p><em>Example:</em></p> + <code type="none"> +> Map = #{a => 1, b => 2, c => 3}. +#{a => 1,b => 2,c => 3} +> Iter = maps:iterator(Map). +[{a,1},{b,2},{c,3}] +> {_, _, Iter1} = maps:next(Iter). +{a,1,[{b,2},{c,3}]} +> {_, _, Iter2} = maps:next(Iter1). +{b,2,[{c,3}]} +> {_, _, Iter3} = maps:next(Iter2). +{c,3,[]} +> maps:next(Iter3). +none</code> + </desc> + </func> + + <func> <name name="put" arity="3"/> <fsummary></fsummary> <desc> diff --git a/lib/stdlib/doc/src/notes.xml b/lib/stdlib/doc/src/notes.xml index d396f1de8f..b61e5b9b9e 100644 --- a/lib/stdlib/doc/src/notes.xml +++ b/lib/stdlib/doc/src/notes.xml @@ -31,6 +31,49 @@ </header> <p>This document describes the changes made to the STDLIB application.</p> +<section><title>STDLIB 3.4.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Make <c>ets:i/1</c> exit cleaner when ^D is input + while browsing a table. Only the old Erlang shell is + affected (<c>erl(1)</c> flag <c>-oldshell</c>). </p> + <p> + Own Id: OTP-14663</p> + </item> + <item> + <p> + Fixed handling of windows UNC paths in module + <c>filename</c>.</p> + <p> + Own Id: OTP-14693</p> + </item> + </list> + </section> + + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + Improve performance of the new string functionality when + handling ASCII characters.</p> + <p> + Own Id: OTP-14670</p> + </item> + <item> + <p> + Added a clarification to the documentation of + <c>unicode:characters_to_list/2</c>.</p> + <p> + Own Id: OTP-14798</p> + </item> + </list> + </section> + +</section> + <section><title>STDLIB 3.4.2</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/stdlib/doc/src/ref_man.xml b/lib/stdlib/doc/src/ref_man.xml index 878a3babc5..68bfddbc71 100644 --- a/lib/stdlib/doc/src/ref_man.xml +++ b/lib/stdlib/doc/src/ref_man.xml @@ -93,6 +93,7 @@ <xi:include href="sys.xml"/> <xi:include href="timer.xml"/> <xi:include href="unicode.xml"/> + <xi:include href="uri_string.xml"/> <xi:include href="win32reg.xml"/> <xi:include href="zip.xml"/> </application> diff --git a/lib/stdlib/doc/src/specs.xml b/lib/stdlib/doc/src/specs.xml index 45b207b13d..d559adf9b6 100644 --- a/lib/stdlib/doc/src/specs.xml +++ b/lib/stdlib/doc/src/specs.xml @@ -60,6 +60,7 @@ <xi:include href="../specs/specs_sys.xml"/> <xi:include href="../specs/specs_timer.xml"/> <xi:include href="../specs/specs_unicode.xml"/> + <xi:include href="../specs/specs_uri_string.xml"/> <xi:include href="../specs/specs_win32reg.xml"/> <xi:include href="../specs/specs_zip.xml"/> </specs> diff --git a/lib/stdlib/doc/src/unicode.xml b/lib/stdlib/doc/src/unicode.xml index e86f45431f..d822aca89c 100644 --- a/lib/stdlib/doc/src/unicode.xml +++ b/lib/stdlib/doc/src/unicode.xml @@ -239,8 +239,13 @@ <c><anno>InEncoding</anno></c>.</p> </item> </list> - <p>Only when <c><anno>InEncoding</anno></c> is one of the UTF - encodings, integers in the list are allowed to be > 255.</p> + <p> + Note that integers in the list always represent code points + regardless of <c><anno>InEncoding</anno></c> passed. If + <c><anno>InEncoding</anno> latin1</c> is passed, only code + points < 256 are allowed; otherwise, all valid unicode code + points are allowed. + </p> <p>If <c><anno>InEncoding</anno></c> is <c>latin1</c>, parameter <c><anno>Data</anno></c> corresponds to the <c>iodata()</c> type, but for <c>unicode</c>, parameter <c><anno>Data</anno></c> can diff --git a/lib/stdlib/doc/src/uri_string.xml b/lib/stdlib/doc/src/uri_string.xml new file mode 100644 index 0000000000..21f470e763 --- /dev/null +++ b/lib/stdlib/doc/src/uri_string.xml @@ -0,0 +1,326 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE erlref SYSTEM "erlref.dtd"> + +<erlref> + <header> + <copyright> + <year>2017</year><year>2017</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>uri_string</title> + <prepared>Péter Dimitrov</prepared> + <docno>1</docno> + <date>2017-10-24</date> + <rev>A</rev> + </header> + <module>uri_string</module> + <modulesummary>URI processing functions.</modulesummary> + <description> + <p>This module contains functions for parsing and handling URIs + (<url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url>) and + form-urlencoded query strings (<url href="https://www.w3.org/TR/html5/forms.html">HTML5</url>). + </p> + <p>A URI is an identifier consisting of a sequence of characters matching the syntax + rule named <em>URI</em> in <url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url>. + </p> + <p> The generic URI syntax consists of a hierarchical sequence of components referred + to as the scheme, authority, path, query, and fragment:</p> + <pre> + URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ] + hier-part = "//" authority path-abempty + / path-absolute + / path-rootless + / path-empty + scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." ) + authority = [ userinfo "@" ] host [ ":" port ] + userinfo = *( unreserved / pct-encoded / sub-delims / ":" ) + + reserved = gen-delims / sub-delims + gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@" + sub-delims = "!" / "$" / "&" / "'" / "(" / ")" + / "*" / "+" / "," / ";" / "=" + + unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" + </pre><br></br> + <p>The interpretation of a URI depends only on the characters used and not on how those + characters are represented in a network protocol.</p> + <p>The functions implemented by this module cover the following use cases:</p> + <list type="bulleted"> + <item>Parsing URIs into its components and returing a map<br></br> + <seealso marker="#parse/1"><c>parse/1</c></seealso> + </item> + <item>Recomposing a map of URI components into a URI string<br></br> + <seealso marker="#recompose/1"><c>recompose/1</c></seealso> + </item> + <item>Changing inbound binary and percent-encoding of URIs<br></br> + <seealso marker="#transcode/2"><c>transcode/2</c></seealso> + </item> + <item>Transforming URIs into a normalized form<br></br> + <seealso marker="#normalize/1"><c>normalize/1</c></seealso> + </item> + <item>Composing form-urlencoded query strings from a list of key-value pairs<br></br> + <seealso marker="#compose_query/1"><c>compose_query/1</c></seealso><br></br> + <seealso marker="#compose_query/2"><c>compose_query/2</c></seealso> + </item> + <item>Dissecting form-urlencoded query strings into a list of key-value pairs<br></br> + <seealso marker="#dissect_query/1"><c>dissect_query/1</c></seealso> + </item> + </list> + <p>There are four different encodings present during the handling of URIs:</p> + <list type="bulleted"> + <item>Inbound binary encoding in binaries</item> + <item>Inbound percent-encoding in lists and binaries</item> + <item>Outbound binary encoding in binaries</item> + <item>Outbound percent-encoding in lists and binaries</item> + </list> + <p>Functions with <c>uri_string()</c> argument accept lists, binaries and + mixed lists (lists with binary elements) as input type. All of the functions but + <c>transcode/2</c> expects input as lists of unicode codepoints, UTF-8 encoded binaries + and UTF-8 percent-encoded URI parts ("%C3%B6" corresponds to the unicode character "ö").</p> + <p>Unless otherwise specified the return value type and encoding are the same as the input + type and encoding. That is, binary input returns binary output, list input returns a list + output but mixed input returns list output.</p> + <p>In case of lists there is only percent-encoding. In binaries, however, both binary encoding + and percent-encoding shall be considered. <c>transcode/2</c> provides the means to convert + between the supported encodings, it takes a <c>uri_string()</c> and a list of options + specifying inbound and outbound encodings.</p> + <p><url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url> does not mandate any specific + character encoding and it is usually defined by the protocol or surrounding text. This library + takes the same assumption, binary and percent-encoding are handled as one configuration unit, + they cannot be set to different values.</p> + </description> + + <datatypes> + <datatype> + <name name="error"/> + <desc> + <p>Error tuple indicating the type of error. Possible values of the second component:</p> + <list type="bulleted"> + <item><c>invalid_character</c></item> + <item><c>invalid_encoding</c></item> + <item><c>invalid_input</c></item> + <item><c>invalid_map</c></item> + <item><c>invalid_percent_encoding</c></item> + <item><c>invalid_scheme</c></item> + <item><c>invalid_uri</c></item> + <item><c>invalid_utf8</c></item> + <item><c>missing_value</c></item> + </list> + <p>The third component is a term providing additional information about the + cause of the error.</p> + </desc> + </datatype> + <datatype> + <name name="uri_map"/> + <desc> + <p>Map holding the main components of a URI.</p> + </desc> + </datatype> + <datatype> + <name name="uri_string"/> + <desc> + <p>List of unicode codepoints, a UTF-8 encoded binary, or a mix of the two, + representing an <url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url> + compliant URI (<em>percent-encoded form</em>). + A URI is a sequence of characters from a very limited set: the letters of + the basic Latin alphabet, digits, and a few special characters.</p> + </desc> + </datatype> + </datatypes> + + <funcs> + + <func> + <name name="compose_query" arity="1"/> + <fsummary>Compose urlencoded query string.</fsummary> + <desc> + <p>Composes a form-urlencoded <c><anno>QueryString</anno></c> based on a + <c><anno>QueryList</anno></c>, a list of non-percent-encoded key-value pairs. + Form-urlencoding is defined in section + 4.10.22.6 of the <url href="https://www.w3.org/TR/html5/forms.html">HTML5</url> + specification. + </p> + <p>See also the opposite operation <seealso marker="#dissect_query/1"> + <c>dissect_query/1</c></seealso>. + </p> + <p><em>Example:</em></p> + <pre> +1> <input>uri_string:compose_query([{"foo bar","1"},{"city","örebro"}]).</input> +<![CDATA["foo+bar=1&city=%C3%B6rebro"]]> +2> <![CDATA[uri_string:compose_query([{<<"foo bar">>,<<"1">>}, +2> {<<"city">>,<<"örebro"/utf8>>}]).]]> +<![CDATA[<<"foo+bar=1&city=%C3%B6rebro">>]]> + </pre> + </desc> + </func> + + <func> + <name name="compose_query" arity="2"/> + <fsummary>Compose urlencoded query string.</fsummary> + <desc> + <p>Same as <c>compose_query/1</c> but with an additional + <c><anno>Options</anno></c> parameter, that controls the encoding ("charset") + used by the encoding algorithm. There are two supported encodings: <c>utf8</c> + (or <c>unicode</c>) and <c>latin1</c>. + </p> + <p>Each character in the entry's name and value that cannot be expressed using + the selected character encoding, is replaced by a string consisting of a U+0026 + AMPERSAND character (<![CDATA[&]]>), a "#" (U+0023) character, one or more ASCII + digits representing the Unicode code point of the character in base ten, and + finally a ";" (U+003B) character. + </p> + <p>Bytes that are out of the range 0x2A, 0x2D, 0x2E, 0x30 to 0x39, 0x41 to 0x5A, 0x5F, + 0x61 to 0x7A, are percent-encoded (U+0025 PERCENT SIGN character (%) followed by + uppercase ASCII hex digits representing the hexadecimal value of the byte). + </p> + <p>See also the opposite operation <seealso marker="#dissect_query/1"> + <c>dissect_query/1</c></seealso>. + </p> + <p><em>Example:</em></p> + <pre> +1> <input>uri_string:compose_query([{"foo bar","1"},{"city","örebro"}],</input> +1> [{encoding, latin1}]). +<![CDATA["foo+bar=1&city=%F6rebro" +2> uri_string:compose_query([{<<"foo bar">>,<<"1">>}, +2> {<<"city">>,<<"東京"/utf8>>}], [{encoding, latin1}]).]]> +<![CDATA[<<"foo+bar=1&city=%26%2326481%3B%26%2320140%3B">>]]> + </pre> + </desc> + </func> + + <func> + <name name="dissect_query" arity="1"/> + <fsummary>Dissect query string.</fsummary> + <desc> + <p>Dissects an urlencoded <c><anno>QueryString</anno></c> and returns a + <c><anno>QueryList</anno></c>, a list of non-percent-encoded key-value pairs. + Form-urlencoding is defined in section + 4.10.22.6 of the <url href="https://www.w3.org/TR/html5/forms.html">HTML5</url> + specification. + </p> + <p>It is not as strict for its input as the decoding algorithm defined by + <url href="https://www.w3.org/TR/html5/forms.html">HTML5</url> + and accepts all unicode characters.</p> + <p>See also the opposite operation <seealso marker="#compose_query/1"> + <c>compose_query/1</c></seealso>. + </p> + <p><em>Example:</em></p> + <pre> +1> <input><![CDATA[uri_string:dissect_query("foo+bar=1&city=%C3%B6rebro").]]></input> +[{"foo bar","1"},{"city","örebro"}] +2> <![CDATA[uri_string:dissect_query(<<"foo+bar=1&city=%26%2326481%3B%26%2320140%3B">>).]]> +<![CDATA[[{<<"foo bar">>,<<"1">>}, + {<<"city">>,<<230,157,177,228,186,172>>}] ]]> + </pre> + </desc> + </func> + + <func> + <name name="normalize" arity="1"/> + <fsummary>Syntax-based normalization.</fsummary> + <desc> + <p>Transforms <c><anno>URIString</anno></c> into a normalized form + using Syntax-Based Normalization as defined by + <url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url>.</p> + <p>This function implements case normalization, percent-encoding + normalization, path segment normalization and scheme based normalization + for HTTP(S) with basic support for FTP, SSH, SFTP and TFTP.</p> + <p><em>Example:</em></p> + <pre> +1> <input>uri_string:normalize("/a/b/c/./../../g").</input> +"/a/g" +2> <![CDATA[uri_string:normalize(<<"mid/content=5/../6">>).]]> +<![CDATA[<<"mid/6">>]]> +3> uri_string:normalize("http://localhost:80"). +"https://localhost/" + </pre> + </desc> + </func> + + <func> + <name name="parse" arity="1"/> + <fsummary>Parse URI into a map.</fsummary> + <desc> + <p>Parses an <url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url> + compliant <c>uri_string()</c> into a <c>uri_map()</c>, that holds the parsed + components of the <c>URI</c>. + If parsing fails, an error tuple is returned.</p> + <p>See also the opposite operation <seealso marker="#recompose/1"> + <c>recompose/1</c></seealso>.</p> + <p><em>Example:</em></p> + <pre> +1> <input>uri_string:parse("foo://[email protected]:8042/over/there?name=ferret#nose").</input> +#{fragment => "nose",host => "example.com", + path => "/over/there",port => 8042,query => "name=ferret", + scheme => foo,userinfo => "user"} +2> <![CDATA[uri_string:parse(<<"foo://[email protected]:8042/over/there?name=ferret">>).]]> +<![CDATA[#{host => <<"example.com">>,path => <<"/over/there">>, + port => 8042,query => <<"name=ferret">>,scheme => <<"foo">>, + userinfo => <<"user">>}]]> + </pre> + </desc> + </func> + + <func> + <name name="recompose" arity="1"/> + <fsummary>Recompose URI.</fsummary> + <desc> + <p>Creates an <url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url> compliant + <c><anno>URIString</anno></c> (percent-encoded), based on the components of + <c><anno>URIMap</anno></c>. + If the <c><anno>URIMap</anno></c> is invalid, an error tuple is returned.</p> + <p>See also the opposite operation <seealso marker="#parse/1"> + <c>parse/1</c></seealso>.</p> + <p><em>Example:</em></p> + <pre> +1> <input>URIMap = #{fragment => "nose", host => "example.com", path => "/over/there",</input> +1> port => 8042, query => "name=ferret", scheme => "foo", userinfo => "user"}. +#{fragment => "top",host => "example.com", + path => "/over/there",port => 8042,query => "?name=ferret", + scheme => foo,userinfo => "user"} + +2> <input>uri_string:recompose(URIMap).</input> +"foo://example.com:8042/over/there?name=ferret#nose"</pre> + </desc> + </func> + + <func> + <name name="transcode" arity="2"/> + <fsummary>Transcode URI.</fsummary> + <desc> + <p>Transcodes an <url href="https://www.ietf.org/rfc/rfc3986.txt">RFC 3986</url> + compliant <c><anno>URIString</anno></c>, + where <c><anno>Options</anno></c> is a list of tagged tuples, specifying the inbound + (<c>in_encoding</c>) and outbound (<c>out_encoding</c>) encodings. <c>in_encoding</c> + and <c>out_encoding</c> specifies both binary encoding and percent-encoding for the + input and output data. Mixed encoding, where binary encoding is not the same as + percent-encoding, is not supported. + If an argument is invalid, an error tuple is returned.</p> + <p><em>Example:</em></p> + <pre> +1> <input><![CDATA[uri_string:transcode(<<"foo%00%00%00%F6bar"/utf32>>,]]></input> +1> [{in_encoding, utf32},{out_encoding, utf8}]). +<![CDATA[<<"foo%C3%B6bar"/utf8>>]]> +2> uri_string:transcode("foo%F6bar", [{in_encoding, latin1}, +2> {out_encoding, utf8}]). +"foo%C3%B6bar" + </pre> + </desc> + </func> + + </funcs> +</erlref> diff --git a/lib/stdlib/src/Makefile b/lib/stdlib/src/Makefile index bf836203ec..8b156929d7 100644 --- a/lib/stdlib/src/Makefile +++ b/lib/stdlib/src/Makefile @@ -121,6 +121,7 @@ MODULES= \ timer \ unicode \ unicode_util \ + uri_string \ win32reg \ zip diff --git a/lib/stdlib/src/base64.erl b/lib/stdlib/src/base64.erl index c8cf6fdffe..6ea4147abf 100644 --- a/lib/stdlib/src/base64.erl +++ b/lib/stdlib/src/base64.erl @@ -24,22 +24,11 @@ -export([encode/1, decode/1, mime_decode/1, encode_to_string/1, decode_to_string/1, mime_decode_to_string/1]). -%%------------------------------------------------------------------------- %% The following type is a subtype of string() for return values %% of (some) functions of this module. -%%------------------------------------------------------------------------- - -type ascii_string() :: [1..255]. -type ascii_binary() :: binary(). -%%------------------------------------------------------------------------- -%% encode_to_string(ASCII) -> Base64String -%% ASCII - string() | binary() -%% Base64String - string() -%% -%% Description: Encodes a plain ASCII string (or binary) into base64. -%%------------------------------------------------------------------------- - -spec encode_to_string(Data) -> Base64String when Data :: ascii_string() | ascii_binary(), Base64String :: ascii_string(). @@ -47,66 +36,67 @@ encode_to_string(Bin) when is_binary(Bin) -> encode_to_string(binary_to_list(Bin)); encode_to_string(List) when is_list(List) -> - encode_l(List). - -%%------------------------------------------------------------------------- -%% encode(ASCII) -> Base64 -%% ASCII - string() | binary() -%% Base64 - binary() -%% -%% Description: Encodes a plain ASCII string (or binary) into base64. -%%------------------------------------------------------------------------- + encode_list_to_string(List). -spec encode(Data) -> Base64 when Data :: ascii_string() | ascii_binary(), Base64 :: ascii_binary(). encode(Bin) when is_binary(Bin) -> - encode_binary(Bin); + encode_binary(Bin, <<>>); encode(List) when is_list(List) -> - list_to_binary(encode_l(List)). - --spec encode_l(ascii_string()) -> ascii_string(). + encode_list(List, <<>>). -encode_l([]) -> +encode_list_to_string([]) -> []; -encode_l([A]) -> - [b64e(A bsr 2), - b64e((A band 3) bsl 4), $=, $=]; -encode_l([A,B]) -> - [b64e(A bsr 2), - b64e(((A band 3) bsl 4) bor (B bsr 4)), - b64e((B band 15) bsl 2), $=]; -encode_l([A,B,C|Ls]) -> - BB = (A bsl 16) bor (B bsl 8) bor C, +encode_list_to_string([B1]) -> + [b64e(B1 bsr 2), + b64e((B1 band 3) bsl 4), $=, $=]; +encode_list_to_string([B1,B2]) -> + [b64e(B1 bsr 2), + b64e(((B1 band 3) bsl 4) bor (B2 bsr 4)), + b64e((B2 band 15) bsl 2), $=]; +encode_list_to_string([B1,B2,B3|Ls]) -> + BB = (B1 bsl 16) bor (B2 bsl 8) bor B3, [b64e(BB bsr 18), b64e((BB bsr 12) band 63), b64e((BB bsr 6) band 63), - b64e(BB band 63) | encode_l(Ls)]. - -encode_binary(Bin) -> - Split = 3*(byte_size(Bin) div 3), - <<Main0:Split/binary,Rest/binary>> = Bin, - Main = << <<(b64e(C)):8>> || <<C:6>> <= Main0 >>, - case Rest of - <<A:6,B:6,C:4>> -> - <<Main/binary,(b64e(A)):8,(b64e(B)):8,(b64e(C bsl 2)):8,$=:8>>; - <<A:6,B:2>> -> - <<Main/binary,(b64e(A)):8,(b64e(B bsl 4)):8,$=:8,$=:8>>; - <<>> -> - Main - end. + b64e(BB band 63) | encode_list_to_string(Ls)]. -%%------------------------------------------------------------------------- -%% mime_decode(Base64) -> ASCII -%% decode(Base64) -> ASCII -%% Base64 - string() | binary() -%% ASCII - binary() -%% -%% Description: Decodes an base64 encoded string to plain ASCII. -%% mime_decode strips away all characters not Base64 before converting, -%% whereas decode crashes if an illegal character is found -%%------------------------------------------------------------------------- +encode_binary(<<>>, A) -> + A; +encode_binary(<<B1:8>>, A) -> + <<A/bits,(b64e(B1 bsr 2)):8,(b64e((B1 band 3) bsl 4)):8,$=:8,$=:8>>; +encode_binary(<<B1:8, B2:8>>, A) -> + <<A/bits,(b64e(B1 bsr 2)):8, + (b64e(((B1 band 3) bsl 4) bor (B2 bsr 4))):8, + (b64e((B2 band 15) bsl 2)):8, $=:8>>; +encode_binary(<<B1:8, B2:8, B3:8, Ls/bits>>, A) -> + BB = (B1 bsl 16) bor (B2 bsl 8) bor B3, + encode_binary(Ls, + <<A/bits,(b64e(BB bsr 18)):8, + (b64e((BB bsr 12) band 63)):8, + (b64e((BB bsr 6) band 63)):8, + (b64e(BB band 63)):8>>). + +encode_list([], A) -> + A; +encode_list([B1], A) -> + <<A/bits,(b64e(B1 bsr 2)):8,(b64e((B1 band 3) bsl 4)):8,$=:8,$=:8>>; +encode_list([B1,B2], A) -> + <<A/bits,(b64e(B1 bsr 2)):8, + (b64e(((B1 band 3) bsl 4) bor (B2 bsr 4))):8, + (b64e((B2 band 15) bsl 2)):8, $=:8>>; +encode_list([B1,B2,B3|Ls], A) -> + BB = (B1 bsl 16) bor (B2 bsl 8) bor B3, + encode_list(Ls, + <<A/bits,(b64e(BB bsr 18)):8, + (b64e((BB bsr 12) band 63)):8, + (b64e((BB bsr 6) band 63)):8, + (b64e(BB band 63)):8>>). + +%% mime_decode strips away all characters not Base64 before +%% converting, whereas decode crashes if an illegal character is found -spec decode(Base64) -> Data when Base64 :: ascii_string() | ascii_binary(), @@ -122,32 +112,13 @@ decode(List) when is_list(List) -> Data :: ascii_binary(). mime_decode(Bin) when is_binary(Bin) -> - mime_decode_binary(<<>>, Bin); + mime_decode_binary(Bin, <<>>); mime_decode(List) when is_list(List) -> - mime_decode(list_to_binary(List)). + mime_decode_list(List, <<>>). --spec decode_l(ascii_string()) -> ascii_string(). - -decode_l(List) -> - L = strip_spaces(List, []), - decode(L, []). - --spec mime_decode_l(ascii_string()) -> ascii_string(). - -mime_decode_l(List) -> - L = strip_illegal(List, [], 0), - decode(L, []). - -%%------------------------------------------------------------------------- -%% mime_decode_to_string(Base64) -> ASCII -%% decode_to_string(Base64) -> ASCII -%% Base64 - string() | binary() -%% ASCII - binary() -%% -%% Description: Decodes an base64 encoded string to plain ASCII. -%% mime_decode strips away all characters not Base64 before converting, -%% whereas decode crashes if an illegal character is found -%%------------------------------------------------------------------------- +%% mime_decode_to_string strips away all characters not Base64 before +%% converting, whereas decode_to_string crashes if an illegal +%% character is found -spec decode_to_string(Base64) -> DataString when Base64 :: ascii_string() | ascii_binary(), @@ -156,7 +127,7 @@ mime_decode_l(List) -> decode_to_string(Bin) when is_binary(Bin) -> decode_to_string(binary_to_list(Bin)); decode_to_string(List) when is_list(List) -> - decode_l(List). + decode_list_to_string(List). -spec mime_decode_to_string(Base64) -> DataString when Base64 :: ascii_string() | ascii_binary(), @@ -165,115 +136,195 @@ decode_to_string(List) when is_list(List) -> mime_decode_to_string(Bin) when is_binary(Bin) -> mime_decode_to_string(binary_to_list(Bin)); mime_decode_to_string(List) when is_list(List) -> - mime_decode_l(List). - -%% One-based decode map. --define(DECODE_MAP, - {bad,bad,bad,bad,bad,bad,bad,bad,ws,ws,bad,bad,ws,bad,bad, %1-15 - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, %16-31 - ws,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,62,bad,bad,bad,63, %32-47 - 52,53,54,55,56,57,58,59,60,61,bad,bad,bad,eq,bad,bad, %48-63 - bad,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14, - 15,16,17,18,19,20,21,22,23,24,25,bad,bad,bad,bad,bad, - bad,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40, - 41,42,43,44,45,46,47,48,49,50,51,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad}). + mime_decode_list_to_string(List). -decode_binary(<<C1:8, Cs/bits>>, A) -> - case element(C1, ?DECODE_MAP) of - ws -> decode_binary(Cs, A); - B1 -> decode_binary(Cs, A, B1) +%% Skipping pad character if not at end of string. Also liberal about +%% excess padding and skipping of other illegal (non-base64 alphabet) +%% characters. See section 3.3 of RFC4648 +mime_decode_list([0 | Cs], A) -> + mime_decode_list(Cs, A); +mime_decode_list([C1 | Cs], A) -> + case b64d(C1) of + B1 when is_integer(B1) -> mime_decode_list(Cs, A, B1); + _ -> mime_decode_list(Cs, A) % eq is padding end; -decode_binary(<<>>, A) -> +mime_decode_list([], A) -> A. -decode_binary(<<C2:8, Cs/bits>>, A, B1) -> - case element(C2, ?DECODE_MAP) of - ws -> decode_binary(Cs, A, B1); - B2 -> decode_binary(Cs, A, B1, B2) +mime_decode_list([0 | Cs], A, B1) -> + mime_decode_list(Cs, A, B1); +mime_decode_list([C2 | Cs], A, B1) -> + case b64d(C2) of + B2 when is_integer(B2) -> + mime_decode_list(Cs, A, B1, B2); + _ -> mime_decode_list(Cs, A, B1) % eq is padding end. -decode_binary(<<C3:8, Cs/bits>>, A, B1, B2) -> - case element(C3, ?DECODE_MAP) of - ws -> decode_binary(Cs, A, B1, B2); - B3 -> decode_binary(Cs, A, B1, B2, B3) +mime_decode_list([0 | Cs], A, B1, B2) -> + mime_decode_list(Cs, A, B1, B2); +mime_decode_list([C3 | Cs], A, B1, B2) -> + case b64d(C3) of + B3 when is_integer(B3) -> + mime_decode_list(Cs, A, B1, B2, B3); + eq=B3 -> + mime_decode_list_after_eq(Cs, A, B1, B2, B3); + _ -> mime_decode_list(Cs, A, B1, B2) end. -decode_binary(<<C4:8, Cs/bits>>, A, B1, B2, B3) -> - case element(C4, ?DECODE_MAP) of - ws -> decode_binary(Cs, A, B1, B2, B3); - eq when B3 =:= eq -> only_ws_binary(Cs, <<A/binary,B1:6,(B2 bsr 4):2>>); - eq -> only_ws_binary(Cs, <<A/binary,B1:6,B2:6,(B3 bsr 2):4>>); - B4 -> decode_binary(Cs, <<A/binary,B1:6,B2:6,B3:6,B4:6>>) +mime_decode_list([0 | Cs], A, B1, B2, B3) -> + mime_decode_list(Cs, A, B1, B2, B3); +mime_decode_list([C4 | Cs], A, B1, B2, B3) -> + case b64d(C4) of + B4 when is_integer(B4) -> + mime_decode_list(Cs, <<A/bits,B1:6,B2:6,B3:6,B4:6>>); + eq -> + mime_decode_list_after_eq(Cs, A, B1, B2, B3); + _ -> mime_decode_list(Cs, A, B1, B2, B3) end. -only_ws_binary(<<>>, A) -> - A; -only_ws_binary(<<C:8, Cs/bits>>, A) -> - case element(C, ?DECODE_MAP) of - ws -> only_ws_binary(Cs, A); - _ -> erlang:error(function_clause) +mime_decode_list_after_eq([0 | Cs], A, B1, B2, B3) -> + mime_decode_list_after_eq(Cs, A, B1, B2, B3); +mime_decode_list_after_eq([C | Cs], A, B1, B2, B3) -> + case b64d(C) of + B when is_integer(B) -> + %% More valid data, skip the eq as invalid + case B3 of + eq -> mime_decode_list(Cs, A, B1, B2, B); + _ -> mime_decode_list(Cs, <<A/bits,B1:6,B2:6,B3:6,B:6>>) + end; + _ -> mime_decode_list_after_eq(Cs, A, B1, B2, B3) + end; +mime_decode_list_after_eq([], A, B1, B2, eq) -> + <<A/bits,B1:6,(B2 bsr 4):2>>; +mime_decode_list_after_eq([], A, B1, B2, B3) -> + <<A/bits,B1:6,B2:6,(B3 bsr 2):4>>. + +mime_decode_binary(<<0:8, Cs/bits>>, A) -> + mime_decode_binary(Cs, A); +mime_decode_binary(<<C1:8, Cs/bits>>, A) -> + case b64d(C1) of + B1 when is_integer(B1) -> mime_decode_binary(Cs, A, B1); + _ -> mime_decode_binary(Cs, A) % eq is padding + end; +mime_decode_binary(<<>>, A) -> + A. + +mime_decode_binary(<<0:8, Cs/bits>>, A, B1) -> + mime_decode_binary(Cs, A, B1); +mime_decode_binary(<<C2:8, Cs/bits>>, A, B1) -> + case b64d(C2) of + B2 when is_integer(B2) -> + mime_decode_binary(Cs, A, B1, B2); + _ -> mime_decode_binary(Cs, A, B1) % eq is padding end. -%% Skipping pad character if not at end of string. Also liberal about -%% excess padding and skipping of other illegal (non-base64 alphabet) -%% characters. See section 3.3 of RFC4648 -mime_decode_binary(Result, <<0:8,T/bits>>) -> - mime_decode_binary(Result, T); -mime_decode_binary(Result0, <<C:8,T/bits>>) -> - case element(C, ?DECODE_MAP) of - Bits when is_integer(Bits) -> - mime_decode_binary(<<Result0/bits,Bits:6>>, T); +mime_decode_binary(<<0:8, Cs/bits>>, A, B1, B2) -> + mime_decode_binary(Cs, A, B1, B2); +mime_decode_binary(<<C3:8, Cs/bits>>, A, B1, B2) -> + case b64d(C3) of + B3 when is_integer(B3) -> + mime_decode_binary(Cs, A, B1, B2, B3); + eq=B3 -> + mime_decode_binary_after_eq(Cs, A, B1, B2, B3); + _ -> mime_decode_binary(Cs, A, B1, B2) + end. + +mime_decode_binary(<<0:8, Cs/bits>>, A, B1, B2, B3) -> + mime_decode_binary(Cs, A, B1, B2, B3); +mime_decode_binary(<<C4:8, Cs/bits>>, A, B1, B2, B3) -> + case b64d(C4) of + B4 when is_integer(B4) -> + mime_decode_binary(Cs, <<A/bits,B1:6,B2:6,B3:6,B4:6>>); eq -> - mime_decode_binary_after_eq(Result0, T, false); - _ -> - mime_decode_binary(Result0, T) + mime_decode_binary_after_eq(Cs, A, B1, B2, B3); + _ -> mime_decode_binary(Cs, A, B1, B2, B3) + end. + +mime_decode_binary_after_eq(<<0:8, Cs/bits>>, A, B1, B2, B3) -> + mime_decode_binary_after_eq(Cs, A, B1, B2, B3); +mime_decode_binary_after_eq(<<C:8, Cs/bits>>, A, B1, B2, B3) -> + case b64d(C) of + B when is_integer(B) -> + %% More valid data, skip the eq as invalid + case B3 of + eq -> mime_decode_binary(Cs, A, B1, B2, B); + _ -> mime_decode_binary(Cs, <<A/bits,B1:6,B2:6,B3:6,B:6>>) + end; + _ -> mime_decode_binary_after_eq(Cs, A, B1, B2, B3) end; -mime_decode_binary(Result, _) -> - true = is_binary(Result), - Result. - -mime_decode_binary_after_eq(Result, <<0:8,T/bits>>, Eq) -> - mime_decode_binary_after_eq(Result, T, Eq); -mime_decode_binary_after_eq(Result0, <<C:8,T/bits>>, Eq) -> - case element(C, ?DECODE_MAP) of - bad -> - mime_decode_binary_after_eq(Result0, T, Eq); - ws -> - mime_decode_binary_after_eq(Result0, T, Eq); +mime_decode_binary_after_eq(<<>>, A, B1, B2, eq) -> + <<A/bits,B1:6,(B2 bsr 4):2>>; +mime_decode_binary_after_eq(<<>>, A, B1, B2, B3) -> + <<A/bits,B1:6,B2:6,(B3 bsr 2):4>>. + +mime_decode_list_to_string([0 | Cs]) -> + mime_decode_list_to_string(Cs); +mime_decode_list_to_string([C1 | Cs]) -> + case b64d(C1) of + B1 when is_integer(B1) -> mime_decode_list_to_string(Cs, B1); + _ -> mime_decode_list_to_string(Cs) % eq is padding + end; +mime_decode_list_to_string([]) -> + []. + +mime_decode_list_to_string([0 | Cs], B1) -> + mime_decode_list_to_string(Cs, B1); +mime_decode_list_to_string([C2 | Cs], B1) -> + case b64d(C2) of + B2 when is_integer(B2) -> + mime_decode_list_to_string(Cs, B1, B2); + _ -> mime_decode_list_to_string(Cs, B1) % eq is padding + end. + +mime_decode_list_to_string([0 | Cs], B1, B2) -> + mime_decode_list_to_string(Cs, B1, B2); +mime_decode_list_to_string([C3 | Cs], B1, B2) -> + case b64d(C3) of + B3 when is_integer(B3) -> + mime_decode_list_to_string(Cs, B1, B2, B3); + eq=B3 -> mime_decode_list_to_string_after_eq(Cs, B1, B2, B3); + _ -> mime_decode_list_to_string(Cs, B1, B2) + end. + +mime_decode_list_to_string([0 | Cs], B1, B2, B3) -> + mime_decode_list_to_string(Cs, B1, B2, B3); +mime_decode_list_to_string([C4 | Cs], B1, B2, B3) -> + case b64d(C4) of + B4 when is_integer(B4) -> + Bits4x6 = (B1 bsl 18) bor (B2 bsl 12) bor (B3 bsl 6) bor B4, + Octet1 = Bits4x6 bsr 16, + Octet2 = (Bits4x6 bsr 8) band 16#ff, + Octet3 = Bits4x6 band 16#ff, + [Octet1, Octet2, Octet3 | mime_decode_list_to_string(Cs)]; eq -> - mime_decode_binary_after_eq(Result0, T, true); - Bits when is_integer(Bits) -> + mime_decode_list_to_string_after_eq(Cs, B1, B2, B3); + _ -> mime_decode_list_to_string(Cs, B1, B2, B3) + end. + +mime_decode_list_to_string_after_eq([0 | Cs], B1, B2, B3) -> + mime_decode_list_to_string_after_eq(Cs, B1, B2, B3); +mime_decode_list_to_string_after_eq([C | Cs], B1, B2, B3) -> + case b64d(C) of + B when is_integer(B) -> %% More valid data, skip the eq as invalid - mime_decode_binary(<<Result0/bits,Bits:6>>, T) + case B3 of + eq -> mime_decode_list_to_string(Cs, B1, B2, B); + _ -> + Bits4x6 = (B1 bsl 18) bor (B2 bsl 12) bor (B3 bsl 6) bor B, + Octet1 = Bits4x6 bsr 16, + Octet2 = (Bits4x6 bsr 8) band 16#ff, + Octet3 = Bits4x6 band 16#ff, + [Octet1, Octet2, Octet3 | mime_decode_list_to_string(Cs)] + end; + _ -> mime_decode_list_to_string_after_eq(Cs, B1, B2, B3) end; -mime_decode_binary_after_eq(Result0, <<>>, Eq) -> - %% No more valid data. - case bit_size(Result0) rem 8 of - 0 -> - %% '====' is not uncommon. - Result0; - 4 when Eq -> - %% enforce at least one more '=' only ignoring illegals and spacing - Split = byte_size(Result0) - 1, - <<Result:Split/bytes,_:4>> = Result0, - Result; - 2 -> - %% remove 2 bits - Split = byte_size(Result0) - 1, - <<Result:Split/bytes,_:2>> = Result0, - Result - end. +mime_decode_list_to_string_after_eq([], B1, B2, eq) -> + binary_to_list(<<B1:6,(B2 bsr 4):2>>); +mime_decode_list_to_string_after_eq([], B1, B2, B3) -> + binary_to_list(<<B1:6,B2:6,(B3 bsr 2):4>>). decode_list([C1 | Cs], A) -> - case element(C1, ?DECODE_MAP) of + case b64d(C1) of ws -> decode_list(Cs, A); B1 -> decode_list(Cs, A, B1) end; @@ -281,122 +332,130 @@ decode_list([], A) -> A. decode_list([C2 | Cs], A, B1) -> - case element(C2, ?DECODE_MAP) of + case b64d(C2) of ws -> decode_list(Cs, A, B1); B2 -> decode_list(Cs, A, B1, B2) end. decode_list([C3 | Cs], A, B1, B2) -> - case element(C3, ?DECODE_MAP) of + case b64d(C3) of ws -> decode_list(Cs, A, B1, B2); B3 -> decode_list(Cs, A, B1, B2, B3) end. decode_list([C4 | Cs], A, B1, B2, B3) -> - case element(C4, ?DECODE_MAP) of + case b64d(C4) of ws -> decode_list(Cs, A, B1, B2, B3); - eq when B3 =:= eq -> only_ws(Cs, <<A/binary,B1:6,(B2 bsr 4):2>>); - eq -> only_ws(Cs, <<A/binary,B1:6,B2:6,(B3 bsr 2):4>>); - B4 -> decode_list(Cs, <<A/binary,B1:6,B2:6,B3:6,B4:6>>) + eq when B3 =:= eq -> only_ws(Cs, <<A/bits,B1:6,(B2 bsr 4):2>>); + eq -> only_ws(Cs, <<A/bits,B1:6,B2:6,(B3 bsr 2):4>>); + B4 -> decode_list(Cs, <<A/bits,B1:6,B2:6,B3:6,B4:6>>) end. -only_ws([], A) -> - A; -only_ws([C | Cs], A) -> - case element(C, ?DECODE_MAP) of - ws -> only_ws(Cs, A); - _ -> erlang:error(function_clause) - end. +decode_binary(<<C1:8, Cs/bits>>, A) -> + case b64d(C1) of + ws -> decode_binary(Cs, A); + B1 -> decode_binary(Cs, A, B1) + end; +decode_binary(<<>>, A) -> + A. -decode([], A) -> A; -decode([$=,$=,C2,C1|Cs], A) -> - Bits2x6 = (b64d(C1) bsl 18) bor (b64d(C2) bsl 12), - Octet1 = Bits2x6 bsr 16, - decode(Cs, [Octet1|A]); -decode([$=,C3,C2,C1|Cs], A) -> - Bits3x6 = (b64d(C1) bsl 18) bor (b64d(C2) bsl 12) - bor (b64d(C3) bsl 6), - Octet1 = Bits3x6 bsr 16, - Octet2 = (Bits3x6 bsr 8) band 16#ff, - decode(Cs, [Octet1,Octet2|A]); -decode([C4,C3,C2,C1| Cs], A) -> - Bits4x6 = (b64d(C1) bsl 18) bor (b64d(C2) bsl 12) - bor (b64d(C3) bsl 6) bor b64d(C4), - Octet1 = Bits4x6 bsr 16, - Octet2 = (Bits4x6 bsr 8) band 16#ff, - Octet3 = Bits4x6 band 16#ff, - decode(Cs, [Octet1,Octet2,Octet3|A]). +decode_binary(<<C2:8, Cs/bits>>, A, B1) -> + case b64d(C2) of + ws -> decode_binary(Cs, A, B1); + B2 -> decode_binary(Cs, A, B1, B2) + end. -%%%======================================================================== -%%% Internal functions -%%%======================================================================== +decode_binary(<<C3:8, Cs/bits>>, A, B1, B2) -> + case b64d(C3) of + ws -> decode_binary(Cs, A, B1, B2); + B3 -> decode_binary(Cs, A, B1, B2, B3) + end. -strip_spaces([], A) -> A; -strip_spaces([$\s|Cs], A) -> strip_spaces(Cs, A); -strip_spaces([$\t|Cs], A) -> strip_spaces(Cs, A); -strip_spaces([$\r|Cs], A) -> strip_spaces(Cs, A); -strip_spaces([$\n|Cs], A) -> strip_spaces(Cs, A); -strip_spaces([C|Cs], A) -> strip_spaces(Cs, [C | A]). +decode_binary(<<C4:8, Cs/bits>>, A, B1, B2, B3) -> + case b64d(C4) of + ws -> decode_binary(Cs, A, B1, B2, B3); + eq when B3 =:= eq -> only_ws_binary(Cs, <<A/bits,B1:6,(B2 bsr 4):2>>); + eq -> only_ws_binary(Cs, <<A/bits,B1:6,B2:6,(B3 bsr 2):4>>); + B4 -> decode_binary(Cs, <<A/bits,B1:6,B2:6,B3:6,B4:6>>) + end. -%% Skipping pad character if not at end of string. Also liberal about -%% excess padding and skipping of other illegal (non-base64 alphabet) -%% characters. See section 3.3 of RFC4648 -strip_illegal([], A, _Cnt) -> +only_ws_binary(<<>>, A) -> A; -strip_illegal([0|Cs], A, Cnt) -> - strip_illegal(Cs, A, Cnt); -strip_illegal([C|Cs], A, Cnt) -> - case element(C, ?DECODE_MAP) of - bad -> - strip_illegal(Cs, A, Cnt); - ws -> - strip_illegal(Cs, A, Cnt); - eq -> - case {tail_contains_more(Cs, false), Cnt rem 4} of - {{[], _}, 0} -> - A; %% Ignore extra = - {{[], true}, 2} -> - [$=|[$=|A]]; %% 'XX==' - {{[], _}, 3} -> - [$=|A]; %% 'XXX=' - {{[H|T], _}, _} -> - %% more data, skip equals - strip_illegal(T, [H|A], Cnt+1) - end; - _ -> - strip_illegal(Cs, [C|A], Cnt+1) +only_ws_binary(<<C:8, Cs/bits>>, A) -> + case b64d(C) of + ws -> only_ws_binary(Cs, A) end. -%% Search the tail for more valid data and remember if we saw -%% another equals along the way. -tail_contains_more([], Eq) -> - {[], Eq}; -tail_contains_more(<<>>, Eq) -> - {<<>>, Eq}; -tail_contains_more([C|T]=More, Eq) -> - case element(C, ?DECODE_MAP) of - bad -> - tail_contains_more(T, Eq); - ws -> - tail_contains_more(T, Eq); - eq -> - tail_contains_more(T, true); - _ -> - {More, Eq} +decode_list_to_string([C1 | Cs]) -> + case b64d(C1) of + ws -> decode_list_to_string(Cs); + B1 -> decode_list_to_string(Cs, B1) end; -tail_contains_more(<<C:8,T/bits>> =More, Eq) -> - case element(C, ?DECODE_MAP) of - bad -> - tail_contains_more(T, Eq); - ws -> - tail_contains_more(T, Eq); - eq -> - tail_contains_more(T, true); - _ -> - {More, Eq} +decode_list_to_string([]) -> + []. + +decode_list_to_string([C2 | Cs], B1) -> + case b64d(C2) of + ws -> decode_list_to_string(Cs, B1); + B2 -> decode_list_to_string(Cs, B1, B2) + end. + +decode_list_to_string([C3 | Cs], B1, B2) -> + case b64d(C3) of + ws -> decode_list_to_string(Cs, B1, B2); + B3 -> decode_list_to_string(Cs, B1, B2, B3) + end. + +decode_list_to_string([C4 | Cs], B1, B2, B3) -> + case b64d(C4) of + ws -> + decode_list_to_string(Cs, B1, B2, B3); + eq when B3 =:= eq -> + only_ws(Cs, binary_to_list(<<B1:6,(B2 bsr 4):2>>)); + eq -> + only_ws(Cs, binary_to_list(<<B1:6,B2:6,(B3 bsr 2):4>>)); + B4 -> + Bits4x6 = (B1 bsl 18) bor (B2 bsl 12) bor (B3 bsl 6) bor B4, + Octet1 = Bits4x6 bsr 16, + Octet2 = (Bits4x6 bsr 8) band 16#ff, + Octet3 = Bits4x6 band 16#ff, + [Octet1, Octet2, Octet3 | decode_list_to_string(Cs)] + end. + +only_ws([], A) -> + A; +only_ws([C | Cs], A) -> + case b64d(C) of + ws -> only_ws(Cs, A) end. - + +%%%======================================================================== +%%% Internal functions +%%%======================================================================== + %% accessors +-compile({inline, [{b64d, 1}]}). +%% One-based decode map. +b64d(X) -> + element(X, + {bad,bad,bad,bad,bad,bad,bad,bad,ws,ws,bad,bad,ws,bad,bad, %1-15 + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, %16-31 + ws,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,62,bad,bad,bad,63, %32-47 + 52,53,54,55,56,57,58,59,60,61,bad,bad,bad,eq,bad,bad, %48-63 + bad,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14, + 15,16,17,18,19,20,21,22,23,24,25,bad,bad,bad,bad,bad, + bad,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40, + 41,42,43,44,45,46,47,48,49,50,51,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad}). + +-compile({inline, [{b64e, 1}]}). b64e(X) -> element(X+1, {$A, $B, $C, $D, $E, $F, $G, $H, $I, $J, $K, $L, $M, $N, @@ -404,9 +463,3 @@ b64e(X) -> $a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n, $o, $p, $q, $r, $s, $t, $u, $v, $w, $x, $y, $z, $0, $1, $2, $3, $4, $5, $6, $7, $8, $9, $+, $/}). - - -b64d(X) -> - b64d_ok(element(X, ?DECODE_MAP)). - -b64d_ok(I) when is_integer(I) -> I. diff --git a/lib/stdlib/src/erl_compile.erl b/lib/stdlib/src/erl_compile.erl index 18d7548fdc..f781312ca2 100644 --- a/lib/stdlib/src/erl_compile.erl +++ b/lib/stdlib/src/erl_compile.erl @@ -188,6 +188,8 @@ parse_dep_option("", T) -> {[makedep,{makedep_output,standard_io}],T}; parse_dep_option("D", T) -> {[makedep],T}; +parse_dep_option("MD", T) -> + {[makedep_side_effect],T}; parse_dep_option("F"++Opt, T0) -> {File,T} = get_option("MF", Opt, T0), {[makedep,{makedep_output,File}],T}; @@ -221,6 +223,7 @@ usage() -> "the dependencies"}, {"-MP","add a phony target for each dependency"}, {"-MD","same as -M -MT file (with default 'file')"}, + {"-MMD","generate dependencies as a side-effect"}, {"-o name","name output directory or file"}, {"-pa path","add path to the front of Erlang's code path"}, {"-pz path","add path to the end of Erlang's code path"}, diff --git a/lib/stdlib/src/erl_eval.erl b/lib/stdlib/src/erl_eval.erl index eafee346eb..4ee11383da 100644 --- a/lib/stdlib/src/erl_eval.erl +++ b/lib/stdlib/src/erl_eval.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2016. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -69,6 +69,9 @@ -type(non_local_function_handler() :: {value, nlfun_handler()} | none). +-define(STACKTRACE, + element(2, erlang:process_info(self(), current_stacktrace))). + %% exprs(ExpressionSeq, Bindings) %% exprs(ExpressionSeq, Bindings, LocalFuncHandler) %% exprs(ExpressionSeq, Bindings, LocalFuncHandler, ExternalFuncHandler) @@ -90,7 +93,7 @@ exprs(Exprs, Bs) -> ok -> exprs(Exprs, Bs, none, none, none); {error,{_Line,_Mod,Error}} -> - erlang:raise(error, Error, [{?MODULE,exprs,2}]) + erlang:raise(error, Error, ?STACKTRACE) end. -spec(exprs(Expressions, Bindings, LocalFunctionHandler) -> @@ -141,7 +144,7 @@ expr(E, Bs) -> ok -> expr(E, Bs, none, none, none); {error,{_Line,_Mod,Error}} -> - erlang:raise(error, Error, [{?MODULE,expr,2}]) + erlang:raise(error, Error, ?STACKTRACE) end. -spec(expr(Expression, Bindings, LocalFunctionHandler) -> @@ -182,7 +185,7 @@ check_command(Es, Bs) -> fun_data(F) when is_function(F) -> case erlang:fun_info(F, module) of - {module,erl_eval} -> + {module,?MODULE} -> case erlang:fun_info(F, env) of {env,[{FBs,_FLf,_FEf,FCs}]} -> {fun_data,FBs,FCs}; @@ -209,8 +212,8 @@ expr({var,_,V}, Bs, _Lf, _Ef, RBs) -> case binding(V, Bs) of {value,Val} -> ret_expr(Val, Bs, RBs); - unbound -> % Should not happen. - erlang:raise(error, {unbound,V}, stacktrace()) + unbound -> % Cannot not happen if checked by erl_lint + erlang:raise(error, {unbound,V}, ?STACKTRACE) end; expr({char,_,C}, Bs, _Lf, _Ef, RBs) -> ret_expr(C, Bs, RBs); @@ -236,13 +239,13 @@ expr({tuple,_,Es}, Bs0, Lf, Ef, RBs) -> {Vs,Bs} = expr_list(Es, Bs0, Lf, Ef), ret_expr(list_to_tuple(Vs), Bs, RBs); expr({record_field,_,_,Name,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {undef_record,Name}, stacktrace()); + erlang:raise(error, {undef_record,Name}, ?STACKTRACE); expr({record_index,_,Name,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {undef_record,Name}, stacktrace()); + erlang:raise(error, {undef_record,Name}, ?STACKTRACE); expr({record,_,Name,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {undef_record,Name}, stacktrace()); + erlang:raise(error, {undef_record,Name}, ?STACKTRACE); expr({record,_,_,Name,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {undef_record,Name}, stacktrace()); + erlang:raise(error, {undef_record,Name}, ?STACKTRACE); %% map expr({map,_,Binding,Es}, Bs0, Lf, Ef, RBs) -> @@ -281,7 +284,7 @@ expr({'fun',_Line,{function,Mod0,Name0,Arity0}}, Bs0, Lf, Ef, RBs) -> ret_expr(F, Bs, RBs); expr({'fun',_Line,{function,Name,Arity}}, _Bs0, _Lf, _Ef, _RBs) -> % R8 %% Don't know what to do... - erlang:raise(error, undef, [{erl_eval,Name,Arity}|stacktrace()]); + erlang:raise(error, undef, [{?MODULE,Name,Arity}|?STACKTRACE]); expr({'fun',Line,{clauses,Cs}} = Ex, Bs, Lf, Ef, RBs) -> %% Save only used variables in the function environment. %% {value,L,V} are hidden while lint finds used variables. @@ -326,7 +329,7 @@ expr({'fun',Line,{clauses,Cs}} = Ex, Bs, Lf, Ef, RBs) -> eval_fun([A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T], Info) end; _Other -> erlang:raise(error, {'argument_limit',{'fun',Line,Cs}}, - stacktrace()) + ?STACKTRACE) end, ret_expr(F, Bs, RBs); expr({named_fun,Line,Name,Cs} = Ex, Bs, Lf, Ef, RBs) -> @@ -378,7 +381,7 @@ expr({named_fun,Line,Name,Cs} = Ex, Bs, Lf, Ef, RBs) -> RF, Info) end; _Other -> erlang:raise(error, {'argument_limit',{named_fun,Line,Name,Cs}}, - stacktrace()) + ?STACKTRACE) end, ret_expr(F, Bs, RBs); expr({call,_,{remote,_,{atom,_,qlc},{atom,_,q}},[{lc,_,_E,_Qs}=LC | As0]}, @@ -422,25 +425,28 @@ expr({call,_,Func0,As0}, Bs0, Lf, Ef, RBs) -> % function or {Mod,Fun} {As,Bs2} = expr_list(As0, Bs1, Lf, Ef), case Func of {M,F} when is_atom(M), is_atom(F) -> - erlang:raise(error, {badfun,Func}, stacktrace()); + erlang:raise(error, {badfun,Func}, ?STACKTRACE); _ -> do_apply(Func, As, Bs2, Ef, RBs) end; expr({'catch',_,Expr}, Bs0, Lf, Ef, RBs) -> - Ref = make_ref(), - case catch {Ref,expr(Expr, Bs0, Lf, Ef, none)} of - {Ref,{value,V,Bs}} -> % Nothing was thrown (guaranteed). - ret_expr(V, Bs, RBs); - Other -> - ret_expr(Other, Bs0, RBs) + try expr(Expr, Bs0, Lf, Ef, none) of + {value,V,Bs} -> + ret_expr(V, Bs, RBs) + catch + throw:Term -> + ret_expr(Term, Bs0, RBs); + exit:Reason -> + ret_expr({'EXIT',Reason}, Bs0, RBs); + error:Reason:Stacktrace -> + ret_expr({'EXIT',{Reason,Stacktrace}}, Bs0, RBs) end; expr({match,_,Lhs,Rhs0}, Bs0, Lf, Ef, RBs) -> {value,Rhs,Bs1} = expr(Rhs0, Bs0, Lf, Ef, none), case match(Lhs, Rhs, Bs1) of {match,Bs} -> ret_expr(Rhs, Bs, RBs); - nomatch -> - erlang:raise(error, {badmatch,Rhs}, stacktrace()) + nomatch -> erlang:raise(error, {badmatch,Rhs}, ?STACKTRACE) end; expr({op,_,Op,A0}, Bs0, Lf, Ef, RBs) -> {value,A,Bs} = expr(A0, Bs0, Lf, Ef, none), @@ -452,7 +458,7 @@ expr({op,_,'andalso',L0,R0}, Bs0, Lf, Ef, RBs) -> {value,R,_} = expr(R0, Bs1, Lf, Ef, none), R; false -> false; - _ -> erlang:raise(error, {badarg,L}, stacktrace()) + _ -> erlang:raise(error, {badarg,L}, ?STACKTRACE) end, ret_expr(V, Bs1, RBs); expr({op,_,'orelse',L0,R0}, Bs0, Lf, Ef, RBs) -> @@ -462,7 +468,7 @@ expr({op,_,'orelse',L0,R0}, Bs0, Lf, Ef, RBs) -> false -> {value,R,_} = expr(R0, Bs1, Lf, Ef, none), R; - _ -> erlang:raise(error, {badarg,L}, stacktrace()) + _ -> erlang:raise(error, {badarg,L}, ?STACKTRACE) end, ret_expr(V, Bs1, RBs); expr({op,_,Op,L0,R0}, Bs0, Lf, Ef, RBs) -> @@ -474,7 +480,7 @@ expr({bin,_,Fs}, Bs0, Lf, Ef, RBs) -> {value,V,Bs} = eval_bits:expr_grp(Fs, Bs0, EvalFun), ret_expr(V, Bs, RBs); expr({remote,_,_,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {badexpr,':'}, stacktrace()); + erlang:raise(error, {badexpr,':'}, ?STACKTRACE); expr({value,_,Val}, Bs, _Lf, _Ef, RBs) -> % Special case straight values. ret_expr(Val, Bs, RBs). @@ -570,7 +576,7 @@ local_func(Func, As, _Bs, {M,F,Eas}, _Ef, RBs) -> local_func2(apply(M, F, [Func,As|Eas]), RBs); %% Default unknown function handler to undefined function. local_func(Func, As0, _Bs0, none, _Ef, _RBs) -> - erlang:raise(error, undef, [{erl_eval,Func,length(As0)}|stacktrace()]). + erlang:raise(error, undef, [{?MODULE,Func,length(As0)}|?STACKTRACE]). local_func2({value,V,Bs}, RBs) -> ret_expr(V, Bs, RBs); @@ -637,7 +643,7 @@ do_apply(Func, As, Bs0, Ef, RBs) -> {{arity, Arity}, Arity} -> eval_fun(FCs, As, FBs, FLf, FEf, NRBs); _ -> - erlang:raise(error, {badarity,{Func,As}},stacktrace()) + erlang:raise(error, {badarity,{Func,As}},?STACKTRACE) end; {{env,[{FBs,FLf,FEf,FCs,FName}]},_} -> NRBs = if @@ -648,7 +654,7 @@ do_apply(Func, As, Bs0, Ef, RBs) -> {{arity, Arity}, Arity} -> eval_named_fun(FCs, As, FBs, FLf, FEf, FName, Func, NRBs); _ -> - erlang:raise(error, {badarity,{Func,As}},stacktrace()) + erlang:raise(error, {badarity,{Func,As}},?STACKTRACE) end; {no_env,none} when RBs =:= value -> %% Make tail recursive calls when possible. @@ -730,7 +736,7 @@ eval_generate([V|Rest], P, Bs0, Lf, Ef, CompFun, Acc) -> eval_generate([], _P, _Bs0, _Lf, _Ef, _CompFun, Acc) -> Acc; eval_generate(Term, _P, _Bs0, _Lf, _Ef, _CompFun, _Acc) -> - erlang:raise(error, {bad_generator,Term}, stacktrace()). + erlang:raise(error, {bad_generator,Term}, ?STACKTRACE). eval_b_generate(<<_/bitstring>>=Bin, P, Bs0, Lf, Ef, CompFun, Acc) -> Mfun = match_fun(Bs0), @@ -746,7 +752,7 @@ eval_b_generate(<<_/bitstring>>=Bin, P, Bs0, Lf, Ef, CompFun, Acc) -> Acc end; eval_b_generate(Term, _P, _Bs0, _Lf, _Ef, _CompFun, _Acc) -> - erlang:raise(error, {bad_generator,Term}, stacktrace()). + erlang:raise(error, {bad_generator,Term}, ?STACKTRACE). eval_filter(F, Bs0, Lf, Ef, CompFun, Acc) -> case erl_lint:is_guard_test(F) of @@ -760,7 +766,7 @@ eval_filter(F, Bs0, Lf, Ef, CompFun, Acc) -> {value,true,Bs1} -> CompFun(Bs1); {value,false,_} -> Acc; {value,V,_} -> - erlang:raise(error, {bad_filter,V}, stacktrace()) + erlang:raise(error, {bad_filter,V}, ?STACKTRACE) end end. @@ -816,7 +822,7 @@ eval_fun([{clause,_,H,G,B}|Cs], As, Bs0, Lf, Ef, RBs) -> end; eval_fun([], As, _Bs, _Lf, _Ef, _RBs) -> erlang:raise(error, function_clause, - [{?MODULE,'-inside-an-interpreted-fun-',As}|stacktrace()]). + [{?MODULE,'-inside-an-interpreted-fun-',As}|?STACKTRACE]). eval_named_fun(As, Fun, {Bs0,Lf,Ef,Cs,Name}) -> @@ -836,7 +842,7 @@ eval_named_fun([{clause,_,H,G,B}|Cs], As, Bs0, Lf, Ef, Name, Fun, RBs) -> end; eval_named_fun([], As, _Bs, _Lf, _Ef, _Name, _Fun, _RBs) -> erlang:raise(error, function_clause, - [{?MODULE,'-inside-an-interpreted-fun-',As}|stacktrace()]). + [{?MODULE,'-inside-an-interpreted-fun-',As}|?STACKTRACE]). %% expr_list(ExpressionList, Bindings) @@ -894,13 +900,13 @@ if_clauses([{clause,_,[],G,B}|Cs], Bs, Lf, Ef, RBs) -> false -> if_clauses(Cs, Bs, Lf, Ef, RBs) end; if_clauses([], _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, if_clause, stacktrace()). + erlang:raise(error, if_clause, ?STACKTRACE). %% try_clauses(Body, CaseClauses, CatchClauses, AfterBody, Bindings, %% LocalFuncHandler, ExtFuncHandler, RBs) -%% When/if variable bindings between the different parts of a -%% try-catch expression are introduced this will have to be rewritten. + try_clauses(B, Cases, Catches, AB, Bs, Lf, Ef, RBs) -> + check_stacktrace_vars(Catches, Bs), try exprs(B, Bs, Lf, Ef, none) of {value,V,Bs1} when Cases =:= [] -> ret_expr(V, Bs1, RBs); @@ -909,23 +915,18 @@ try_clauses(B, Cases, Catches, AB, Bs, Lf, Ef, RBs) -> {B2,Bs2} -> exprs(B2, Bs2, Lf, Ef, RBs); nomatch -> - erlang:raise(error, {try_clause,V}, stacktrace()) + erlang:raise(error, {try_clause,V}, ?STACKTRACE) end catch - Class:Reason when Catches =:= [] -> - %% Rethrow - erlang:raise(Class, Reason, stacktrace()); - Class:Reason -> -%%% %% Set stacktrace -%%% try erlang:raise(Class, Reason, stacktrace()) -%%% catch _:_ -> ok -%%% end, - V = {Class,Reason,erlang:get_stacktrace()}, - case match_clause(Catches, [V],Bs, Lf, Ef) of + Class:Reason:Stacktrace when Catches =:= [] -> + erlang:raise(Class, Reason, Stacktrace); + Class:Reason:Stacktrace -> + V = {Class,Reason,Stacktrace}, + case match_clause(Catches, [V], Bs, Lf, Ef) of {B2,Bs2} -> exprs(B2, Bs2, Lf, Ef, RBs); nomatch -> - erlang:raise(Class, Reason, stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end after if AB =:= [] -> @@ -935,6 +936,23 @@ try_clauses(B, Cases, Catches, AB, Bs, Lf, Ef, RBs) -> end end. +check_stacktrace_vars([{clause,_,[{tuple,_,[_,_,STV]}],_,_}|Cs], Bs) -> + case STV of + {var,_,V} -> + case binding(V, Bs) of + {value, _} -> + erlang:raise(error, stacktrace_bound, ?STACKTRACE); + unbound -> + check_stacktrace_vars(Cs, Bs) + end; + _ -> + erlang:raise(error, + {illegal_stacktrace_variable,STV}, + ?STACKTRACE) + end; +check_stacktrace_vars([], _Bs) -> + ok. + %% case_clauses(Value, Clauses, Bindings, LocalFuncHandler, ExtFuncHandler, %% RBs) @@ -943,7 +961,7 @@ case_clauses(Val, Cs, Bs, Lf, Ef, RBs) -> {B, Bs1} -> exprs(B, Bs1, Lf, Ef, RBs); nomatch -> - erlang:raise(error, {case_clause,Val}, stacktrace()) + erlang:raise(error, {case_clause,Val}, ?STACKTRACE) end. %% @@ -1018,7 +1036,7 @@ guard0([G|Gs], Bs0, Lf, Ef) -> {value,false,_} -> false end; false -> - erlang:raise(error, guard_expr, stacktrace()) + erlang:raise(error, guard_expr, ?STACKTRACE) end; guard0([], _Bs, _Lf, _Ef) -> true. @@ -1073,7 +1091,7 @@ match(Pat, Term, Bs) -> match(Pat, Term, Bs, BBs) -> case catch match1(Pat, Term, Bs, BBs) of invalid -> - erlang:raise(error, {illegal_pattern,Pat}, stacktrace()); + erlang:raise(error, {illegal_pattern,Pat}, ?STACKTRACE); Other -> Other end. @@ -1254,7 +1272,7 @@ merge_bindings(Bs1, Bs2) -> case orddict:find(Name, Bs) of {ok,Val} -> Bs; %Already with SAME value {ok,V1} -> - erlang:raise(error, {badmatch,V1}, stacktrace()); + erlang:raise(error, {badmatch,V1}, ?STACKTRACE); error -> orddict:store(Name, Val, Bs) end end, Bs2, orddict:to_list(Bs1)). @@ -1264,7 +1282,7 @@ merge_bindings(Bs1, Bs2) -> %% fun (Name, Val, Bs) -> %% case orddict:find(Name, Bs) of %% {ok,Val} -> orddict:erase(Name, Bs); -%% {ok,V1} -> erlang:raise(error,{badmatch,V1},stacktrace()); +%% {ok,V1} -> erlang:raise(error,{badmatch,V1},?STACKTRACE); %% error -> Bs %% end %% end, Bs2, Bs1). @@ -1326,7 +1344,3 @@ ret_expr(_Old, New) -> New. line(Expr) -> element(2, Expr). - -%% {?MODULE,expr,3} is still the stacktrace, despite the -%% fact that expr() now takes two, three or four arguments... -stacktrace() -> [{?MODULE,expr,3}]. diff --git a/lib/stdlib/src/erl_lint.erl b/lib/stdlib/src/erl_lint.erl index f58cb35cea..1930c462e8 100644 --- a/lib/stdlib/src/erl_lint.erl +++ b/lib/stdlib/src/erl_lint.erl @@ -144,6 +144,7 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) -> :: dict:dict(ta(), #typeinfo{}), exp_types=gb_sets:empty() %Exported types :: gb_sets:set(ta()), + in_try_head=false :: boolean(), %In a try head. catch_scope = none %Inside/outside try or catch :: catch_scope() }). @@ -312,6 +313,10 @@ format_error({unused_var, V}) -> io_lib:format("variable ~w is unused", [V]); format_error({variable_in_record_def,V}) -> io_lib:format("variable ~w in record definition", [V]); +format_error({stacktrace_guard,V}) -> + io_lib:format("stacktrace variable ~w must not be used in a guard", [V]); +format_error({stacktrace_bound,V}) -> + io_lib:format("stacktrace variable ~w must not be previously bound", [V]); %% --- binaries --- format_error({undefined_bittype,Type}) -> io_lib:format("bit type ~tw undefined", [Type]); @@ -3218,11 +3223,11 @@ is_module_dialyzer_option(Option) -> try_clauses(Scs, Ccs, In, Vt, St0) -> {Csvt0,St1} = icrt_clauses(Scs, Vt, St0), - St2 = St1#lint{catch_scope=try_catch}, + St2 = St1#lint{catch_scope=try_catch,in_try_head=true}, {Csvt1,St3} = icrt_clauses(Ccs, Vt, St2), Csvt = Csvt0 ++ Csvt1, UpdVt = icrt_export(Csvt, Vt, In, St3), - {UpdVt,St3}. + {UpdVt,St3#lint{in_try_head=false}}. %% icrt_clauses(Clauses, In, ImportVarTable, State) -> %% {UpdVt,State}. @@ -3239,12 +3244,29 @@ icrt_clauses(Cs, Vt, St) -> mapfoldl(fun (C, St0) -> icrt_clause(C, Vt, St0) end, St, Cs). icrt_clause({clause,_Line,H,G,B}, Vt0, #lint{catch_scope=Scope}=St0) -> - {Hvt,Binvt,St1} = head(H, Vt0, St0), - Vt1 = vtupdate(Hvt, Binvt), - {Gvt,St2} = guard(G, vtupdate(Vt1, Vt0), St1), - Vt2 = vtupdate(Gvt, Vt1), - {Bvt,St3} = exprs(B, vtupdate(Vt2, Vt0), St2), - {vtupdate(Bvt, Vt2),St3#lint{catch_scope=Scope}}. + Vt1 = taint_stack_var(Vt0, H, St0), + {Hvt,Binvt,St1} = head(H, Vt1, St0), + Vt2 = vtupdate(Hvt, Binvt), + Vt3 = taint_stack_var(Vt2, H, St0), + {Gvt,St2} = guard(G, vtupdate(Vt3, Vt0), St1#lint{in_try_head=false}), + Vt4 = vtupdate(Gvt, Vt2), + {Bvt,St3} = exprs(B, vtupdate(Vt4, Vt0), St2), + {vtupdate(Bvt, Vt4),St3#lint{catch_scope=Scope}}. + +taint_stack_var(Vt, Pat, #lint{in_try_head=true}) -> + [{tuple,_,[_,_,{var,_,Stk}]}] = Pat, + case Stk of + '_' -> + Vt; + _ -> + lists:map(fun({V,{bound,Used,Lines}}) when V =:= Stk -> + {V,{stacktrace,Used,Lines}}; + (B) -> + B + end, Vt) + end; +taint_stack_var(Vt, _Pat, #lint{in_try_head=false}) -> + Vt. icrt_export(Vts, Vt, {Tag,Attrs}, St) -> {_File,Loc} = loc(Attrs, St), @@ -3484,6 +3506,9 @@ pat_var(V, Line, Vt, Bvt, St) -> {[{V,{bound,used,Ls}}],[], %% As this is matching, exported vars are risky. add_warning(Line, {exported_var,V,From}, St)}; + {ok,{stacktrace,_Usage,Ls}} -> + {[{V,{bound,used,Ls}}],[], + add_error(Line, {stacktrace_bound,V}, St)}; error when St#lint.recdef_top -> {[],[{V,{bound,unused,[Line]}}], add_error(Line, {variable_in_record_def,V}, St)}; @@ -3541,6 +3566,9 @@ expr_var(V, Line, Vt, St) -> false -> {[{V,{{export,From},used,Ls}}],St} end; + {ok,{stacktrace,_Usage,Ls}} -> + {[{V,{bound,used,Ls}}], + add_error(Line, {stacktrace_guard,V}, St)}; error -> {[{V,{bound,used,[Line]}}], add_error(Line, {unbound_var,V}, St)} diff --git a/lib/stdlib/src/erl_parse.yrl b/lib/stdlib/src/erl_parse.yrl index 6e72d64acc..14ca24362e 100644 --- a/lib/stdlib/src/erl_parse.yrl +++ b/lib/stdlib/src/erl_parse.yrl @@ -29,6 +29,10 @@ clause_args clause_guard clause_body expr expr_100 expr_150 expr_160 expr_200 expr_300 expr_400 expr_500 expr_600 expr_700 expr_800 expr_max +pat_expr pat_expr_200 pat_expr_300 pat_expr_400 pat_expr_500 +pat_expr_600 pat_expr_700 pat_expr_800 +pat_expr_max map_pat_expr record_pat_expr +pat_argument_list pat_exprs list tail list_comprehension lc_expr lc_exprs binary_comprehension @@ -37,7 +41,7 @@ record_expr record_tuple record_field record_fields map_expr map_tuple map_field map_field_assoc map_field_exact map_fields map_key if_expr if_clause if_clauses case_expr cr_clause cr_clauses receive_expr fun_expr fun_clause fun_clauses atom_or_var integer_or_var -try_expr try_catch try_clause try_clauses +try_expr try_catch try_clause try_clauses try_opt_stacktrace function_call argument_list exprs guard atomic strings @@ -66,7 +70,7 @@ char integer float atom string var 'spec' 'callback' % helper dot. -Expect 2. +Expect 0. Rootsymbol form. @@ -210,7 +214,7 @@ function_clause -> atom clause_args clause_guard clause_body : {clause,?anno('$1'),element(3, '$1'),'$2','$3','$4'}. -clause_args -> argument_list : element(1, '$1'). +clause_args -> pat_argument_list : element(1, '$1'). clause_guard -> 'when' guard : '$2'. clause_guard -> '$empty' : []. @@ -275,6 +279,53 @@ expr_max -> receive_expr : '$1'. expr_max -> fun_expr : '$1'. expr_max -> try_expr : '$1'. +pat_expr -> pat_expr_200 '=' pat_expr : {match,?anno('$2'),'$1','$3'}. +pat_expr -> pat_expr_200 : '$1'. + +pat_expr_200 -> pat_expr_300 comp_op pat_expr_300 : + ?mkop2('$1', '$2', '$3'). +pat_expr_200 -> pat_expr_300 : '$1'. + +pat_expr_300 -> pat_expr_400 list_op pat_expr_300 : + ?mkop2('$1', '$2', '$3'). +pat_expr_300 -> pat_expr_400 : '$1'. + +pat_expr_400 -> pat_expr_400 add_op pat_expr_500 : + ?mkop2('$1', '$2', '$3'). +pat_expr_400 -> pat_expr_500 : '$1'. + +pat_expr_500 -> pat_expr_500 mult_op pat_expr_600 : + ?mkop2('$1', '$2', '$3'). +pat_expr_500 -> pat_expr_600 : '$1'. + +pat_expr_600 -> prefix_op pat_expr_700 : + ?mkop1('$1', '$2'). +pat_expr_600 -> map_pat_expr : '$1'. +pat_expr_600 -> pat_expr_700 : '$1'. + +pat_expr_700 -> record_pat_expr : '$1'. +pat_expr_700 -> pat_expr_800 : '$1'. + +pat_expr_800 -> pat_expr_max : '$1'. + +pat_expr_max -> var : '$1'. +pat_expr_max -> atomic : '$1'. +pat_expr_max -> list : '$1'. +pat_expr_max -> binary : '$1'. +pat_expr_max -> tuple : '$1'. +pat_expr_max -> '(' pat_expr ')' : '$2'. + +map_pat_expr -> '#' map_tuple : + {map, ?anno('$1'),'$2'}. +map_pat_expr -> pat_expr_max '#' map_tuple : + {map, ?anno('$2'),'$1','$3'}. +map_pat_expr -> map_pat_expr '#' map_tuple : + {map, ?anno('$2'),'$1','$3'}. + +record_pat_expr -> '#' atom '.' atom : + {record_index,?anno('$1'),element(3, '$2'),'$4'}. +record_pat_expr -> '#' atom record_tuple : + {record,?anno('$1'),element(3, '$2'),'$3'}. list -> '[' ']' : {nil,?anno('$1')}. list -> '[' expr tail : {cons,?anno('$1'),'$2','$3'}. @@ -397,6 +448,10 @@ case_expr -> 'case' expr 'of' cr_clauses 'end' : cr_clauses -> cr_clause : ['$1']. cr_clauses -> cr_clause ';' cr_clauses : ['$1' | '$3']. +%% FIXME: merl in syntax_tools depends on patterns in a 'case' being +%% full expressions. Therefore, we can't use pat_expr here. There +%% should be a better way. + cr_clause -> expr clause_guard clause_body : {clause,?anno('$1'),['$1'],'$2','$3'}. @@ -424,11 +479,11 @@ integer_or_var -> var : '$1'. fun_clauses -> fun_clause : ['$1']. fun_clauses -> fun_clause ';' fun_clauses : ['$1' | '$3']. -fun_clause -> argument_list clause_guard clause_body : +fun_clause -> pat_argument_list clause_guard clause_body : {Args,Anno} = '$1', {clause,Anno,'fun',Args,'$2','$3'}. -fun_clause -> var argument_list clause_guard clause_body : +fun_clause -> var pat_argument_list clause_guard clause_body : {clause,element(2, '$1'),element(3, '$1'),element(1, '$2'),'$3','$4'}. try_expr -> 'try' exprs 'of' cr_clauses try_catch : @@ -446,24 +501,31 @@ try_catch -> 'after' exprs 'end' : try_clauses -> try_clause : ['$1']. try_clauses -> try_clause ';' try_clauses : ['$1' | '$3']. -try_clause -> expr clause_guard clause_body : +try_clause -> pat_expr clause_guard clause_body : A = ?anno('$1'), {clause,A,[{tuple,A,[{atom,A,throw},'$1',{var,A,'_'}]}],'$2','$3'}. -try_clause -> atom ':' expr clause_guard clause_body : +try_clause -> atom ':' pat_expr try_opt_stacktrace clause_guard clause_body : A = ?anno('$1'), - {clause,A,[{tuple,A,['$1','$3',{var,A,'_'}]}],'$4','$5'}. -try_clause -> var ':' expr clause_guard clause_body : + {clause,A,[{tuple,A,['$1','$3',{var,A,'$4'}]}],'$5','$6'}. +try_clause -> var ':' pat_expr try_opt_stacktrace clause_guard clause_body : A = ?anno('$1'), - {clause,A,[{tuple,A,['$1','$3',{var,A,'_'}]}],'$4','$5'}. + {clause,A,[{tuple,A,['$1','$3',{var,A,'$4'}]}],'$5','$6'}. +try_opt_stacktrace -> ':' var : element(3, '$2'). +try_opt_stacktrace -> '$empty' : '_'. argument_list -> '(' ')' : {[],?anno('$1')}. argument_list -> '(' exprs ')' : {'$2',?anno('$1')}. +pat_argument_list -> '(' ')' : {[],?anno('$1')}. +pat_argument_list -> '(' pat_exprs ')' : {'$2',?anno('$1')}. exprs -> expr : ['$1']. exprs -> expr ',' exprs : ['$1' | '$3']. +pat_exprs -> pat_expr : ['$1']. +pat_exprs -> pat_expr ',' pat_exprs : ['$1' | '$3']. + guard -> exprs : ['$1']. guard -> exprs ';' guard : ['$1'|'$3']. diff --git a/lib/stdlib/src/erl_tar.erl b/lib/stdlib/src/erl_tar.erl index b04cdb3609..d8b8f466b1 100644 --- a/lib/stdlib/src/erl_tar.erl +++ b/lib/stdlib/src/erl_tar.erl @@ -189,7 +189,7 @@ table(Name) -> %% Returns a list of names of the files in the tar file Name. %% Options accepted: compressed, verbose, cooked. -spec table(open_handle(), [compressed | verbose | cooked]) -> - {ok, [tar_entry()]} | {error, term()}. + {ok, [string() | tar_entry()]} | {error, term()}. table(Name, Opts) when is_list(Opts) -> foldl_read(Name, fun table1/4, [], table_opts(Opts)). diff --git a/lib/stdlib/src/ets.erl b/lib/stdlib/src/ets.erl index b6548626f3..adef1640be 100644 --- a/lib/stdlib/src/ets.erl +++ b/lib/stdlib/src/ets.erl @@ -277,7 +277,7 @@ match_spec_compile(_) -> erlang:nif_error(undef). -spec match_spec_run_r(List, CompiledMatchSpec, list()) -> list() when - List :: [tuple()], + List :: [term()], CompiledMatchSpec :: comp_match_spec(). match_spec_run_r(_, _, _) -> @@ -517,7 +517,7 @@ update_element(_, _, _) -> -opaque comp_match_spec() :: reference(). -spec match_spec_run(List, CompiledMatchSpec) -> list() when - List :: [tuple()], + List :: [term()], CompiledMatchSpec :: comp_match_spec(). match_spec_run(List, CompiledMS) -> diff --git a/lib/stdlib/src/eval_bits.erl b/lib/stdlib/src/eval_bits.erl index 631faa3be5..bb86a65c72 100644 --- a/lib/stdlib/src/eval_bits.erl +++ b/lib/stdlib/src/eval_bits.erl @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2016. All Rights Reserved. +%% Copyright Ericsson AB 1999-2018. 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. @@ -25,6 +25,9 @@ -export([expr_grp/3,expr_grp/5,match_bits/6, match_bits/7,bin_gen/6]). +-define(STACKTRACE, + element(2, erlang:process_info(self(), current_stacktrace))). + %% Types used in this module: %% @type bindings(). An abstract structure for bindings between %% variables and values (the environment) @@ -93,9 +96,9 @@ eval_exp_field1(V, Size, Unit, Type, Endian, Sign) -> eval_exp_field(V, Size, Unit, Type, Endian, Sign) catch error:system_limit -> - error(system_limit); + erlang:raise(error, system_limit, ?STACKTRACE); error:_ -> - error(badarg) + erlang:raise(error, badarg, ?STACKTRACE) end. eval_exp_field(Val, Size, Unit, integer, little, signed) -> @@ -131,7 +134,7 @@ eval_exp_field(Val, all, Unit, binary, _, _) -> Size when Size rem Unit =:= 0 -> <<Val:Size/binary-unit:1>>; _ -> - error(badarg) + erlang:raise(error, badarg, ?STACKTRACE) end; eval_exp_field(Val, Size, Unit, binary, _, _) -> <<Val:(Size*Unit)/binary-unit:1>>. @@ -377,12 +380,12 @@ make_bit_type(Line, default, Type0) -> {ok,all,Bt} -> {{atom,Line,all},erl_bits:as_list(Bt)}; {ok,undefined,Bt} -> {{atom,Line,undefined},erl_bits:as_list(Bt)}; {ok,Size,Bt} -> {{integer,Line,Size},erl_bits:as_list(Bt)}; - {error,Reason} -> error(Reason) + {error,Reason} -> erlang:raise(error, Reason, ?STACKTRACE) end; make_bit_type(_Line, Size, Type0) -> %Size evaluates to an integer or 'all' case erl_bits:set_bit_type(Size, Type0) of {ok,Size,Bt} -> {Size,erl_bits:as_list(Bt)}; - {error,Reason} -> error(Reason) + {error,Reason} -> erlang:raise(error, Reason, ?STACKTRACE) end. match_check_size(Mfun, Size, Bs) -> @@ -405,9 +408,3 @@ match_check_size(_, {value,_,_}, _Bs, _AllowAll) -> ok; %From the debugger. match_check_size(_, _, _Bs, _AllowAll) -> throw(invalid). - -%% error(Reason) -> exception thrown -%% Throw a nice-looking exception, similar to exceptions from erl_eval. -error(Reason) -> - erlang:raise(error, Reason, [{erl_eval,expr,3}]). - diff --git a/lib/stdlib/src/filelib.erl b/lib/stdlib/src/filelib.erl index 0f90b3fc33..de839be5cf 100644 --- a/lib/stdlib/src/filelib.erl +++ b/lib/stdlib/src/filelib.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2017. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. @@ -582,17 +582,16 @@ default_search_rules() -> {"", ".c", c_source_search_rules()}, {"", ".in", basic_source_search_rules()}, %% plain old directory rules, backwards compatible - {"", ""}, - {"ebin","src"}, - {"ebin","esrc"} - ]. + {"", ""}] ++ erl_source_search_rules(). basic_source_search_rules() -> (erl_source_search_rules() ++ c_source_search_rules()). erl_source_search_rules() -> - [{"ebin","src"}, {"ebin","esrc"}]. + [{"ebin","src"}, {"ebin","esrc"}, + {"ebin",filename:join("src", "*")}, + {"ebin",filename:join("esrc", "*")}]. c_source_search_rules() -> [{"priv","c_src"}, {"priv","src"}, {"bin","c_src"}, {"bin","src"}, {"", "src"}]. @@ -672,8 +671,16 @@ try_dir_rule(Dir, Filename, From, To) -> Src = filename:join(NewDir, Filename), case is_regular(Src) of true -> {ok, Src}; - false -> error + false -> find_regular_file(wildcard(Src)) end; false -> error end. + +find_regular_file([]) -> + error; +find_regular_file([File|Files]) -> + case is_regular(File) of + true -> {ok, File}; + false -> find_regular_file(Files) + end. diff --git a/lib/stdlib/src/gen.erl b/lib/stdlib/src/gen.erl index 33af0aed8f..0e6f49d99f 100644 --- a/lib/stdlib/src/gen.erl +++ b/lib/stdlib/src/gen.erl @@ -49,6 +49,7 @@ | {'logfile', string()}. -type option() :: {'timeout', timeout()} | {'debug', [debug_flag()]} + | {'hibernate_after', timeout()} | {'spawn_opt', [proc_lib:spawn_option()]}. -type options() :: [option()]. @@ -147,6 +148,10 @@ init_it2(GenMod, Starter, Parent, Name, Mod, Args, Options) -> call(Process, Label, Request) -> call(Process, Label, Request, ?default_timeout). +%% Optimize a common case. +call(Process, Label, Request, Timeout) when is_pid(Process), + Timeout =:= infinity orelse is_integer(Timeout) andalso Timeout >= 0 -> + do_call(Process, Label, Request, Timeout); call(Process, Label, Request, Timeout) when Timeout =:= infinity; is_integer(Timeout), Timeout >= 0 -> Fun = fun(Pid) -> do_call(Pid, Label, Request, Timeout) end, diff --git a/lib/stdlib/src/gen_event.erl b/lib/stdlib/src/gen_event.erl index a9b98911e2..73e4457bd0 100644 --- a/lib/stdlib/src/gen_event.erl +++ b/lib/stdlib/src/gen_event.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -125,7 +125,8 @@ | {'logfile', string()}. -type option() :: {'timeout', timeout()} | {'debug', [debug_flag()]} - | {'spawn_opt', [proc_lib:spawn_option()]}. + | {'spawn_opt', [proc_lib:spawn_option()]} + | {'hibernate_after', timeout()}. -type emgr_ref() :: atom() | {atom(), atom()} | {'global', atom()} | {'via', atom(), term()} | pid(). -type start_ret() :: {'ok', pid()} | {'error', term()}. diff --git a/lib/stdlib/src/gen_fsm.erl b/lib/stdlib/src/gen_fsm.erl index 96a53426e2..8c7db65563 100644 --- a/lib/stdlib/src/gen_fsm.erl +++ b/lib/stdlib/src/gen_fsm.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -198,7 +198,7 @@ %%% start(Name, Mod, Args, Options) %%% start_link(Mod, Args, Options) %%% start_link(Name, Mod, Args, Options) where: -%%% Name ::= {local, atom()} | {global, atom()} | {via, atom(), term()} +%%% Name ::= {local, atom()} | {global, term()} | {via, atom(), term()} %%% Mod ::= atom(), callback module implementing the 'real' fsm %%% Args ::= term(), init arguments (to Mod:init/1) %%% Options ::= [{debug, [Flag]}] diff --git a/lib/stdlib/src/gen_statem.erl b/lib/stdlib/src/gen_statem.erl index cd6312855d..1a7736fc7e 100644 --- a/lib/stdlib/src/gen_statem.erl +++ b/lib/stdlib/src/gen_statem.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2016-2017. All Rights Reserved. +%% Copyright Ericsson AB 2016-2018. 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. @@ -78,9 +78,11 @@ -type data() :: term(). -type event_type() :: - {'call',From :: from()} | 'cast' | 'info' | - 'timeout' | {'timeout', Name :: term()} | 'state_timeout' | - 'internal'. + external_event_type() | timeout_event_type() | 'internal'. +-type external_event_type() :: + {'call',From :: from()} | 'cast' | 'info'. +-type timeout_event_type() :: + 'timeout' | {'timeout', Name :: term()} | 'state_timeout'. -type callback_mode_result() :: callback_mode() | [callback_mode() | state_enter()]. @@ -138,7 +140,9 @@ -type enter_action() :: 'hibernate' | % Set the hibernate option {'hibernate', Hibernate :: hibernate()} | - %% + timeout_action() | + reply_action(). +-type timeout_action() :: (Timeout :: event_timeout()) | % {timeout,Timeout} {'timeout', % Set the event_timeout option Time :: event_timeout(), EventContent :: term()} | @@ -159,9 +163,7 @@ {'state_timeout', % Set the state_timeout option Time :: state_timeout(), EventContent :: term(), - Options :: (timeout_option() | [timeout_option()])} | - %% - reply_action(). + Options :: (timeout_option() | [timeout_option()])}. -type reply_action() :: {'reply', % Reply to a caller From :: from(), Reply :: term()}. @@ -320,7 +322,13 @@ handle_event/4 % For callback_mode() =:= handle_event_function ]). + + %% Type validation functions +-compile( + {inline, + [callback_mode/1, state_enter/1, from/1, event_type/1]}). +%% callback_mode(CallbackMode) -> case CallbackMode of state_functions -> true; @@ -328,6 +336,14 @@ callback_mode(CallbackMode) -> _ -> false end. %% +state_enter(StateEnter) -> + case StateEnter of + state_enter -> + true; + _ -> + false + end. +%% from({Pid,_}) when is_pid(Pid) -> true; from(_) -> false. %% @@ -351,6 +367,48 @@ event_type(Type) -> STACKTRACE(), try throw(ok) catch _ -> erlang:get_stacktrace() end). +-define(not_sys_debug, []). +%% +%% This is a macro to only evaluate arguments if Debug =/= []. +%% Debug is evaluated multiple times. +-define( + sys_debug(Debug, NameState, Entry), + case begin Debug end of + ?not_sys_debug -> + begin Debug end; + _ -> + sys_debug(begin Debug end, begin NameState end, begin Entry end) + end). + +-record(state, + {callback_mode = undefined :: callback_mode() | undefined, + state_enter = false :: boolean(), + module :: atom(), + name :: atom(), + state :: term(), + data :: term(), + postponed = [] :: [{event_type(),term()}], + %% + timer_refs = #{} :: % timer ref => the timer's event type + #{reference() => timeout_event_type()}, + timer_types = #{} :: % timer's event type => timer ref + #{timeout_event_type() => reference()}, + cancel_timers = 0 :: non_neg_integer(), + %% We add a timer to both timer_refs and timer_types + %% when we start it. When we request an asynchronous + %% timer cancel we remove it from timer_types. When + %% the timer cancel message arrives we remove it from + %% timer_refs. + %% + hibernate = false :: boolean(), + hibernate_after = infinity :: timeout()}). + +-record(trans_opts, + {hibernate = false, + postpone = false, + timeouts_r = [], + next_events_r = []}). + %%%========================================================================== %%% API @@ -422,6 +480,10 @@ stop(ServerRef, Reason, Timeout) -> %% Send an event to a state machine that arrives with type 'event' -spec cast(ServerRef :: server_ref(), Msg :: term()) -> ok. +cast(ServerRef, Msg) when is_pid(ServerRef) -> + send(ServerRef, wrap_cast(Msg)); +cast(ServerRef, Msg) when is_atom(ServerRef) -> + send(ServerRef, wrap_cast(Msg)); cast({global,Name}, Msg) -> try global:send(Name, wrap_cast(Msg)) of _ -> ok @@ -435,10 +497,6 @@ cast({via,RegMod,Name}, Msg) -> _:_ -> ok end; cast({Name,Node} = ServerRef, Msg) when is_atom(Name), is_atom(Node) -> - send(ServerRef, wrap_cast(Msg)); -cast(ServerRef, Msg) when is_atom(ServerRef) -> - send(ServerRef, wrap_cast(Msg)); -cast(ServerRef, Msg) when is_pid(ServerRef) -> send(ServerRef, wrap_cast(Msg)). %% Call a state machine (synchronous; a reply is expected) that @@ -455,73 +513,16 @@ call(ServerRef, Request) -> {'clean_timeout',T :: timeout()} | {'dirty_timeout',T :: timeout()}) -> Reply :: term(). +call(ServerRef, Request, infinity = T = Timeout) -> + call_dirty(ServerRef, Request, Timeout, T); +call(ServerRef, Request, {dirty_timeout, T} = Timeout) -> + call_dirty(ServerRef, Request, Timeout, T); +call(ServerRef, Request, {clean_timeout, T} = Timeout) -> + call_clean(ServerRef, Request, Timeout, T); +call(ServerRef, Request, {_, _} = Timeout) -> + erlang:error(badarg, [ServerRef,Request,Timeout]); call(ServerRef, Request, Timeout) -> - case parse_timeout(Timeout) of - {dirty_timeout,T} -> - try gen:call(ServerRef, '$gen_call', Request, T) of - {ok,Reply} -> - Reply - catch - Class:Reason -> - erlang:raise( - Class, - {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, - erlang:get_stacktrace()) - end; - {clean_timeout,T} -> - %% Call server through proxy process to dodge any late reply - Ref = make_ref(), - Self = self(), - Pid = spawn( - fun () -> - Self ! - try gen:call( - ServerRef, '$gen_call', Request, T) of - Result -> - {Ref,Result} - catch Class:Reason -> - {Ref,Class,Reason, - erlang:get_stacktrace()} - end - end), - Mref = monitor(process, Pid), - receive - {Ref,Result} -> - demonitor(Mref, [flush]), - case Result of - {ok,Reply} -> - Reply - end; - {Ref,Class,Reason,Stacktrace} -> - demonitor(Mref, [flush]), - erlang:raise( - Class, - {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, - Stacktrace); - {'DOWN',Mref,_,_,Reason} -> - %% There is a theoretical possibility that the - %% proxy process gets killed between try--of and ! - %% so this clause is in case of that - exit(Reason) - end; - Error when is_atom(Error) -> - erlang:error(Error, [ServerRef,Request,Timeout]) - end. - -parse_timeout(Timeout) -> - case Timeout of - {clean_timeout,_} -> - Timeout; - {dirty_timeout,_} -> - Timeout; - {_,_} -> - %% Be nice and throw a badarg for speling errors - badarg; - infinity -> - {dirty_timeout,infinity}; - T -> - {clean_timeout,T} - end. + call_clean(ServerRef, Request, Timeout, Timeout). %% Reply from a state machine callback to whom awaits in call/2 -spec reply([reply_action()] | reply_action()) -> ok. @@ -530,6 +531,7 @@ reply({reply,From,Reply}) -> reply(Replies) when is_list(Replies) -> replies(Replies). %% +-compile({inline, [reply/2]}). -spec reply(From :: from(), Reply :: term()) -> ok. reply({To,Tag}, Reply) when is_pid(To) -> Msg = {Tag,Reply}, @@ -579,9 +581,59 @@ enter_loop(Module, Opts, State, Data, Server, Actions) -> %%--------------------------------------------------------------------------- %% API helpers +-compile({inline, [wrap_cast/1]}). wrap_cast(Event) -> {'$gen_cast',Event}. +call_dirty(ServerRef, Request, Timeout, T) -> + try gen:call(ServerRef, '$gen_call', Request, T) of + {ok,Reply} -> + Reply + catch + Class:Reason -> + erlang:raise( + Class, + {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, + erlang:get_stacktrace()) + end. + +call_clean(ServerRef, Request, Timeout, T) -> + %% Call server through proxy process to dodge any late reply + Ref = make_ref(), + Self = self(), + Pid = spawn( + fun () -> + Self ! + try gen:call( + ServerRef, '$gen_call', Request, T) of + Result -> + {Ref,Result} + catch Class:Reason -> + {Ref,Class,Reason, + erlang:get_stacktrace()} + end + end), + Mref = monitor(process, Pid), + receive + {Ref,Result} -> + demonitor(Mref, [flush]), + case Result of + {ok,Reply} -> + Reply + end; + {Ref,Class,Reason,Stacktrace} -> + demonitor(Mref, [flush]), + erlang:raise( + Class, + {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, + Stacktrace); + {'DOWN',Mref,_,_,Reason} -> + %% There is a theoretical possibility that the + %% proxy process gets killed between try--of and ! + %% so this clause is in case of that + exit(Reason) + end. + replies([{reply,From,Reply}|Replies]) -> reply(From, Reply), replies(Replies); @@ -606,60 +658,28 @@ enter(Module, Opts, State, Data, Server, Actions, Parent) -> %% The values should already have been type checked Name = gen:get_proc_name(Server), Debug = gen:debug_options(Name, Opts), - HibernateAfterTimeout = gen:hibernate_after(Opts), - Events = [], - P = [], + HibernateAfterTimeout = gen:hibernate_after(Opts), + Events = [], Event = {internal,init_state}, %% We enforce {postpone,false} to ensure that %% our fake Event gets discarded, thought it might get logged - NewActions = - if - is_list(Actions) -> - Actions ++ [{postpone,false}]; - true -> - [Actions,{postpone,false}] - end, - TimerRefs = #{}, - %% Key: timer ref - %% Value: the timer type i.e the timer's event type - %% - TimerTypes = #{}, - %% Key: timer type i.e the timer's event type - %% Value: timer ref - %% - %% We add a timer to both timer_refs and timer_types - %% when we start it. When we request an asynchronous - %% timer cancel we remove it from timer_types. When - %% the timer cancel message arrives we remove it from - %% timer_refs. - %% - Hibernate = false, - CancelTimers = 0, - S = #{ - callback_mode => undefined, - state_enter => false, - module => Module, - name => Name, - state => State, - data => Data, - postponed => P, - %% - %% The following fields are finally set from to the arguments to - %% loop_event_actions/9 when it finally loops back to loop/3 - %% in loop_event_result/11 - timer_refs => TimerRefs, - timer_types => TimerTypes, - hibernate => Hibernate, - hibernate_after => HibernateAfterTimeout, - cancel_timers => CancelTimers - }, - NewDebug = sys_debug(Debug, S, State, {enter,Event,State}), + NewActions = listify(Actions) ++ [{postpone,false}], + S = + #state{ + module = Module, + name = Name, + state = State, + data = Data, + hibernate_after = HibernateAfterTimeout}, + CallEnter = true, + NewDebug = ?sys_debug(Debug, {Name,State}, {enter,Event,State}), case call_callback_mode(S) of - {ok,NewS} -> + #state{} = NewS -> loop_event_actions( Parent, NewDebug, NewS, - Events, Event, State, Data, NewActions, true); - {Class,Reason,Stacktrace} -> + Events, Event, State, Data, #trans_opts{}, + NewActions, CallEnter); + [Class,Reason,Stacktrace] -> terminate( Class, Reason, Stacktrace, NewDebug, S, [Event|Events]) @@ -684,10 +704,8 @@ init_it(Starter, Parent, ServerRef, Module, Args, Opts) -> proc_lib:init_ack(Starter, {error,Reason}), error_info( Class, Reason, Stacktrace, - #{name => Name, - callback_mode => undefined, - state_enter => false}, - [], [], undefined), + #state{name = Name}, + [], undefined), erlang:raise(Class, Reason, Stacktrace) end. @@ -717,10 +735,8 @@ init_result(Starter, Parent, ServerRef, Module, Result, Opts) -> proc_lib:init_ack(Starter, {error,Error}), error_info( error, Error, ?STACKTRACE(), - #{name => Name, - callback_mode => undefined, - state_enter => false}, - [], [], undefined), + #state{name = Name}, + [], undefined), exit(Error) end. @@ -734,9 +750,10 @@ system_terminate(Reason, _Parent, Debug, S) -> terminate(exit, Reason, ?STACKTRACE(), Debug, S, []). system_code_change( - #{module := Module, - state := State, - data := Data} = S, + #state{ + module = Module, + state = State, + data = Data} = S, _Mod, OldVsn, Extra) -> case try Module:code_change(OldVsn, State, Data, Extra) @@ -746,29 +763,31 @@ system_code_change( of {ok,NewState,NewData} -> {ok, - S#{callback_mode := undefined, - state := NewState, - data := NewData}}; + S#state{ + callback_mode = undefined, + state = NewState, + data = NewData}}; {ok,_} = Error -> error({case_clause,Error}); Error -> Error end. -system_get_state(#{state := State, data := Data}) -> +system_get_state(#state{state = State, data = Data}) -> {ok,{State,Data}}. system_replace_state( StateFun, - #{state := State, - data := Data} = S) -> + #state{ + state = State, + data = Data} = S) -> {NewState,NewData} = Result = StateFun({State,Data}), - {ok,Result,S#{state := NewState, data := NewData}}. + {ok,Result,S#state{state = NewState, data = NewData}}. format_status( Opt, [PDict,SysState,Parent,Debug, - #{name := Name, postponed := P} = S]) -> + #state{name = Name, postponed = P} = S]) -> Header = gen:format_status_header("Status for state machine", Name), Log = sys:get_debug(log, Debug, []), [{header,Header}, @@ -787,6 +806,9 @@ format_status( %% them, not as the real erlang messages. Use trace for that. %%--------------------------------------------------------------------------- +sys_debug(Debug, NameState, Entry) -> + sys:handle_debug(Debug, fun print_event/3, NameState, Entry). + print_event(Dev, {in,Event}, {Name,State}) -> io:format( Dev, "*DBG* ~tp receive ~ts in state ~tp~n", @@ -819,15 +841,6 @@ event_string(Event) -> io_lib:format("~tw ~tp", [EventType,EventContent]) end. -sys_debug(Debug, #{name := Name}, State, Entry) -> - case Debug of - [] -> - Debug; - _ -> - sys:handle_debug( - Debug, fun print_event/3, {Name,State}, Entry) - end. - %%%========================================================================== %%% Internal callbacks @@ -842,14 +855,16 @@ wakeup_from_hibernate(Parent, Debug, S) -> %% and detours through sys:handle_system_message/7 and proc_lib:hibernate/3 %% Entry point for system_continue/3 -loop(Parent, Debug, #{hibernate := true, cancel_timers := 0} = S) -> +loop(Parent, Debug, #state{hibernate = true, cancel_timers = 0} = S) -> loop_hibernate(Parent, Debug, S); loop(Parent, Debug, S) -> loop_receive(Parent, Debug, S). loop_hibernate(Parent, Debug, S) -> + %% %% Does not return but restarts process at %% wakeup_from_hibernate/3 that jumps to loop_receive/3 + %% proc_lib:hibernate( ?MODULE, wakeup_from_hibernate, [Parent,Debug,S]), error( @@ -857,17 +872,18 @@ loop_hibernate(Parent, Debug, S) -> {wakeup_from_hibernate,3}}). %% Entry point for wakeup_from_hibernate/3 -loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) -> +loop_receive( + Parent, Debug, #state{hibernate_after = HibernateAfterTimeout} = S) -> + %% receive Msg -> case Msg of {system,Pid,Req} -> - #{hibernate := Hibernate} = S, %% Does not return but tail recursively calls %% system_continue/3 that jumps to loop/3 sys:handle_system_msg( Req, Pid, Parent, ?MODULE, Debug, S, - Hibernate); + S#state.hibernate); {'EXIT',Parent,Reason} = EXIT -> %% EXIT is not a 2-tuple therefore %% not an event but this will stand out @@ -875,9 +891,9 @@ loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) -> Q = [EXIT], terminate(exit, Reason, ?STACKTRACE(), Debug, S, Q); {timeout,TimerRef,TimerMsg} -> - #{timer_refs := TimerRefs, - timer_types := TimerTypes, - hibernate := Hibernate} = S, + #state{ + timer_refs = TimerRefs, + timer_types = TimerTypes} = S, case TimerRefs of #{TimerRef := TimerType} -> %% We know of this timer; is it a running @@ -887,7 +903,6 @@ loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) -> #{TimerType := TimerRef} -> %% The timer type maps back to this %% timer ref, so it was a running timer - Event = {TimerType,TimerMsg}, %% Unregister the triggered timeout NewTimerRefs = maps:remove(TimerRef, TimerRefs), @@ -895,11 +910,10 @@ loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) -> maps:remove(TimerType, TimerTypes), loop_receive_result( Parent, Debug, - S#{ - timer_refs := NewTimerRefs, - timer_types := NewTimerTypes}, - Hibernate, - Event); + S#state{ + timer_refs = NewTimerRefs, + timer_types = NewTimerTypes}, + TimerType, TimerMsg); _ -> %% This was a late timeout message %% from timer being cancelled, so @@ -909,14 +923,13 @@ loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) -> end; _ -> %% Not our timer; present it as an event - Event = {info,Msg}, - loop_receive_result( - Parent, Debug, S, Hibernate, Event) + loop_receive_result(Parent, Debug, S, info, Msg) end; {cancel_timer,TimerRef,_} -> - #{timer_refs := TimerRefs, - cancel_timers := CancelTimers, - hibernate := Hibernate} = S, + #state{ + timer_refs = TimerRefs, + cancel_timers = CancelTimers, + hibernate = Hibernate} = S, case TimerRefs of #{TimerRef := _} -> %% We must have requested a cancel @@ -926,9 +939,9 @@ loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) -> maps:remove(TimerRef, TimerRefs), NewCancelTimers = CancelTimers - 1, NewS = - S#{ - timer_refs := NewTimerRefs, - cancel_timers := NewCancelTimers}, + S#state{ + timer_refs = NewTimerRefs, + cancel_timers = NewCancelTimers}, if Hibernate =:= true, NewCancelTimers =:= 0 -> %% No more cancel_timer msgs to expect; @@ -940,238 +953,631 @@ loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) -> _ -> %% Not our cancel_timer msg; %% present it as an event - Event = {info,Msg}, - loop_receive_result( - Parent, Debug, S, Hibernate, Event) + loop_receive_result(Parent, Debug, S, info, Msg) end; _ -> %% External msg - #{hibernate := Hibernate} = S, - Event = - case Msg of - {'$gen_call',From,Request} -> - {{call,From},Request}; - {'$gen_cast',E} -> - {cast,E}; - _ -> - {info,Msg} - end, - loop_receive_result( - Parent, Debug, S, Hibernate, Event) + case Msg of + {'$gen_call',From,Request} -> + loop_receive_result( + Parent, Debug, S, {call,From}, Request); + {'$gen_cast',Cast} -> + loop_receive_result(Parent, Debug, S, cast, Cast); + _ -> + loop_receive_result(Parent, Debug, S, info, Msg) + end end after HibernateAfterTimeout -> loop_hibernate(Parent, Debug, S) end. +loop_receive_result(Parent, ?not_sys_debug, S, Type, Content) -> + %% Here is the queue of not yet handled events created + Events = [], + loop_event(Parent, ?not_sys_debug, S, Events, Type, Content); loop_receive_result( - Parent, Debug, - #{state := State, - timer_types := TimerTypes, cancel_timers := CancelTimers} = S, - Hibernate, Event) -> - %% From now the 'hibernate' field in S is invalid - %% and will be restored when looping back - %% in loop_event_result/11 - NewDebug = sys_debug(Debug, S, State, {in,Event}), + Parent, Debug, #state{name = Name, state = State} = S, Type, Content) -> + NewDebug = sys_debug(Debug, {Name,State}, {in,{Type,Content}}), %% Here is the queue of not yet handled events created Events = [], - %% Cancel any running event timer - case - cancel_timer_by_type(timeout, TimerTypes, CancelTimers) - of - {_,CancelTimers} -> - %% No timer cancelled - loop_event(Parent, NewDebug, S, Events, Event, Hibernate); - {NewTimerTypes,NewCancelTimers} -> - %% The timer is removed from NewTimerTypes but - %% remains in TimerRefs until we get - %% the cancel_timer msg - NewS = - S#{ - timer_types := NewTimerTypes, - cancel_timers := NewCancelTimers}, - loop_event(Parent, NewDebug, NewS, Events, Event, Hibernate) - end. + loop_event(Parent, NewDebug, S, Events, Type, Content). %% Entry point for handling an event, received or enqueued loop_event( + Parent, Debug, #state{hibernate = Hibernate} = S, + Events, Type, Content) -> + %% + case Hibernate of + true -> + %% + %% If (this old) Hibernate is true here it can only be + %% because it was set from an event action + %% and we did not go into hibernation since there were + %% events in queue, so we do what the user + %% might rely on i.e collect garbage which + %% would have happened if we actually hibernated + %% and immediately was awakened. + %% + _ = garbage_collect(), + loop_event_state_function( + Parent, Debug, S, Events, Type, Content); + false -> + loop_event_state_function( + Parent, Debug, S, Events, Type, Content) + end. + +%% Call the state function +loop_event_state_function( Parent, Debug, - #{state := State, data := Data} = S, - Events, {Type,Content} = Event, Hibernate) -> + #state{state = State, data = Data} = S, + Events, Type, Content) -> + %% + %% The field 'hibernate' in S is now invalid and will be + %% restored when looping back to loop/3 or loop_event/6. %% - %% If (this old) Hibernate is true here it can only be - %% because it was set from an event action - %% and we did not go into hibernation since there were - %% events in queue, so we do what the user - %% might rely on i.e collect garbage which - %% would have happened if we actually hibernated - %% and immediately was awakened - Hibernate andalso garbage_collect(), + Event = {Type,Content}, + TransOpts = false, case call_state_function(S, Type, Content, State, Data) of - {ok,Result,NewS} -> - {NextState,NewData,Actions,EnterCall} = - parse_event_result( - true, Debug, NewS, - Events, Event, State, Data, Result), - loop_event_actions( - Parent, Debug, NewS, - Events, Event, NextState, NewData, Actions, EnterCall); - {Class,Reason,Stacktrace} -> + {Result, NewS} -> + loop_event_result( + Parent, Debug, NewS, + Events, Event, State, Data, TransOpts, Result); + [Class,Reason,Stacktrace] -> terminate( - Class, Reason, Stacktrace, Debug, S, - [Event|Events]) + Class, Reason, Stacktrace, Debug, S, [Event|Events]) end. -loop_event_actions( - Parent, Debug, - #{state := State, state_enter := StateEnter} = S, - Events, Event, NextState, NewData, - Actions, EnterCall) -> - %% Hibernate is reborn here as false being - %% the default value from parse_actions/4 - case parse_actions(Debug, S, State, Actions) of - {ok,NewDebug,Hibernate,TimeoutsR,Postpone,NextEventsR} -> - if - StateEnter, EnterCall -> - loop_event_enter( - Parent, NewDebug, S, - Events, Event, NextState, NewData, - Hibernate, TimeoutsR, Postpone, NextEventsR); - true -> - loop_event_result( - Parent, NewDebug, S, - Events, Event, NextState, NewData, - Hibernate, TimeoutsR, Postpone, NextEventsR) - end; - {Class,Reason,Stacktrace} -> +%% Make a state enter call to the state function +loop_event_state_enter( + Parent, Debug, #state{state = PrevState} = S, + Events, Event, NextState, NewData, TransOpts) -> + %% + case call_state_function(S, enter, PrevState, NextState, NewData) of + {Result, NewS} -> + loop_event_result( + Parent, Debug, NewS, + Events, Event, NextState, NewData, TransOpts, Result); + [Class,Reason,Stacktrace] -> terminate( - Class, Reason, Stacktrace, Debug, S, - [Event|Events]) + Class, Reason, Stacktrace, Debug, S, [Event|Events]) end. -loop_event_enter( - Parent, Debug, #{state := State} = S, - Events, Event, NextState, NewData, - Hibernate, TimeoutsR, Postpone, NextEventsR) -> - case call_state_function(S, enter, State, NextState, NewData) of - {ok,Result,NewS} -> - case parse_event_result( - false, Debug, NewS, - Events, Event, NextState, NewData, Result) of - {_,NewerData,Actions,EnterCall} -> - loop_event_enter_actions( - Parent, Debug, NewS, - Events, Event, NextState, NewerData, - Hibernate, TimeoutsR, Postpone, NextEventsR, - Actions, EnterCall) - end; - {Class,Reason,Stacktrace} -> - terminate( - Class, Reason, Stacktrace, Debug, - S#{ - state := NextState, - data := NewData, - hibernate := Hibernate}, - [Event|Events]) +%% Process the result from the state function. +%% When TransOpts =:= false it was a state function call, +%% otherwise it is an option tuple and it was a state enter call. +%% +loop_event_result( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, Result) -> + %% + case Result of + {next_state,State,NewData} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + [], false); + {next_state,NextState,NewData} + when TransOpts =:= false -> + loop_event_actions( + Parent, Debug, S, + Events, Event, NextState, NewData, TransOpts, + [], true); + {next_state,State,NewData,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + Actions, false); + {next_state,NextState,NewData,Actions} + when TransOpts =:= false -> + loop_event_actions( + Parent, Debug, S, + Events, Event, NextState, NewData, TransOpts, + Actions, true); + %% + {keep_state,NewData} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + [], false); + {keep_state,NewData,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + Actions, false); + %% + keep_state_and_data -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, + [], false); + {keep_state_and_data,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, + Actions, false); + %% + {repeat_state,NewData} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + [], true); + {repeat_state,NewData,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + Actions, true); + %% + repeat_state_and_data -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, + [], true); + {repeat_state_and_data,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, + Actions, true); + %% + stop -> + terminate( + exit, normal, ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]); + {stop,Reason} -> + terminate( + exit, Reason, ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]); + {stop,Reason,NewData} -> + terminate( + exit, Reason, ?STACKTRACE(), Debug, + S#state{ + state = State, data = NewData, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]); + %% + {stop_and_reply,Reason,Replies} -> + reply_then_terminate( + exit, Reason, ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events], Replies); + {stop_and_reply,Reason,Replies,NewData} -> + reply_then_terminate( + exit, Reason, ?STACKTRACE(), Debug, + S#state{ + state = State, data = NewData, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events], Replies); + %% + _ -> + terminate( + error, + {bad_return_from_state_function,Result}, + ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]) end. -loop_event_enter_actions( - Parent, Debug, #{state_enter := StateEnter} = S, - Events, Event, NextState, NewData, - Hibernate, TimeoutsR, Postpone, NextEventsR, - Actions, EnterCall) -> - case - parse_enter_actions( - Debug, S, NextState, Actions, Hibernate, TimeoutsR) - of - {ok,NewDebug,NewHibernate,NewTimeoutsR,_,_} -> - if - StateEnter, EnterCall -> - loop_event_enter( - Parent, NewDebug, S, - Events, Event, NextState, NewData, - NewHibernate, NewTimeoutsR, Postpone, NextEventsR); - true -> - loop_event_result( - Parent, NewDebug, S, - Events, Event, NextState, NewData, - NewHibernate, NewTimeoutsR, Postpone, NextEventsR) - end; - {Class,Reason,Stacktrace} -> - terminate( - Class, Reason, Stacktrace, Debug, - S#{ - state := NextState, - data := NewData, - hibernate := Hibernate}, - [Event|Events]) +-compile({inline, [hibernate_in_trans_opts/1]}). +hibernate_in_trans_opts(false) -> + (#trans_opts{})#trans_opts.hibernate; +hibernate_in_trans_opts(#trans_opts{hibernate = Hibernate}) -> + Hibernate. + +%% Ensure that Actions are a list +loop_event_actions( + Parent, Debug, S, + Events, Event, NextState, NewerData, TransOpts, + Actions, CallEnter) -> + loop_event_actions_list( + Parent, Debug, S, + Events, Event, NextState, NewerData, TransOpts, + listify(Actions), CallEnter). + +%% Process actions from the state function +loop_event_actions_list( + Parent, Debug, #state{state_enter = StateEnter} = S, + Events, Event, NextState, NewerData, TransOpts, + Actions, CallEnter) -> + %% + case parse_actions(TransOpts, Debug, S, Actions) of + {NewDebug,NewTransOpts} + when StateEnter, CallEnter -> + loop_event_state_enter( + Parent, NewDebug, S, + Events, Event, NextState, NewerData, NewTransOpts); + {NewDebug,NewTransOpts} -> + loop_event_done( + Parent, NewDebug, S, + Events, Event, NextState, NewerData, NewTransOpts); + [Class,Reason,Stacktrace,NewDebug] -> + terminate( + Class, Reason, Stacktrace, NewDebug, + S#state{ + state = NextState, + data = NewerData, + hibernate = TransOpts#trans_opts.hibernate}, + [Event|Events]) end. -loop_event_result( +parse_actions(false, Debug, S, Actions) -> + parse_actions(true, Debug, S, Actions, #trans_opts{}); +parse_actions(TransOpts, Debug, S, Actions) -> + parse_actions(false, Debug, S, Actions, TransOpts). +%% +parse_actions(_StateCall, Debug, _S, [], TransOpts) -> + {Debug,TransOpts}; +parse_actions(StateCall, Debug, S, [Action|Actions], TransOpts) -> + case Action of + %% Actual actions + {reply,From,Reply} -> + parse_actions_reply( + StateCall, Debug, S, Actions, TransOpts, From, Reply); + %% + %% Actions that set options + {hibernate,NewHibernate} when is_boolean(NewHibernate) -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{hibernate = NewHibernate}); + hibernate -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{hibernate = true}); + %% + {postpone,NewPostpone} when not NewPostpone orelse StateCall -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{postpone = NewPostpone}); + postpone when StateCall -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{postpone = true}); + %% + {next_event,Type,Content} -> + parse_actions_next_event( + StateCall, Debug, S, Actions, TransOpts, Type, Content); + %% + _ -> + parse_actions_timeout( + StateCall, Debug, S, Actions, TransOpts, Action) + end. + +parse_actions_reply( + StateCall, ?not_sys_debug, S, Actions, TransOpts, + From, Reply) -> + %% + case from(From) of + true -> + reply(From, Reply), + parse_actions(StateCall, ?not_sys_debug, S, Actions, TransOpts); + false -> + [error, + {bad_action_from_state_function,{reply,From,Reply}}, + ?STACKTRACE(), + ?not_sys_debug] + end; +parse_actions_reply( + StateCall, Debug, #state{name = Name, state = State} = S, + Actions, TransOpts, From, Reply) -> + %% + case from(From) of + true -> + reply(From, Reply), + NewDebug = sys_debug(Debug, {Name,State}, {out,Reply,From}), + parse_actions(StateCall, NewDebug, S, Actions, TransOpts); + false -> + [error, + {bad_action_from_state_function,{reply,From,Reply}}, + ?STACKTRACE(), + Debug] + end. + +parse_actions_next_event( + StateCall, ?not_sys_debug, S, + Actions, TransOpts, Type, Content) -> + case event_type(Type) of + true when StateCall -> + NextEventsR = TransOpts#trans_opts.next_events_r, + parse_actions( + StateCall, ?not_sys_debug, S, Actions, + TransOpts#trans_opts{ + next_events_r = [{Type,Content}|NextEventsR]}); + _ -> + [error, + {bad_action_from_state_function,{next_events,Type,Content}}, + ?STACKTRACE(), + ?not_sys_debug] + end; +parse_actions_next_event( + StateCall, Debug, #state{name = Name, state = State} = S, + Actions, TransOpts, Type, Content) -> + case event_type(Type) of + true when StateCall -> + NewDebug = sys_debug(Debug, {Name,State}, {in,{Type,Content}}), + NextEventsR = TransOpts#trans_opts.next_events_r, + parse_actions( + StateCall, NewDebug, S, Actions, + TransOpts#trans_opts{ + next_events_r = [{Type,Content}|NextEventsR]}); + _ -> + [error, + {bad_action_from_state_function,{next_events,Type,Content}}, + ?STACKTRACE(), + Debug] + end. + +parse_actions_timeout( + StateCall, Debug, S, Actions, TransOpts, + {TimerType,Time,TimerMsg,TimerOpts} = AbsoluteTimeout) -> + %% + case classify_timer(Time, listify(TimerOpts)) of + absolute -> + parse_actions_timeout_add( + StateCall, Debug, S, Actions, + TransOpts, AbsoluteTimeout); + relative -> + RelativeTimeout = {TimerType,Time,TimerMsg}, + parse_actions_timeout_add( + StateCall, Debug, S, Actions, + TransOpts, RelativeTimeout); + badarg -> + [error, + {bad_action_from_state_function,AbsoluteTimeout}, + ?STACKTRACE(), + Debug] + end; +parse_actions_timeout( + StateCall, Debug, S, Actions, TransOpts, + {_,Time,_} = RelativeTimeout) -> + case classify_timer(Time, []) of + relative -> + parse_actions_timeout_add( + StateCall, Debug, S, Actions, + TransOpts, RelativeTimeout); + badarg -> + [error, + {bad_action_from_state_function,RelativeTimeout}, + ?STACKTRACE(), + Debug] + end; +parse_actions_timeout( + StateCall, Debug, S, Actions, TransOpts, + Timeout) -> + case classify_timer(Timeout, []) of + relative -> + parse_actions_timeout_add( + StateCall, Debug, S, Actions, TransOpts, Timeout); + badarg -> + [error, + {bad_action_from_state_function,Timeout}, + ?STACKTRACE(), + Debug] + end. + +parse_actions_timeout_add( + StateCall, Debug, S, Actions, + #trans_opts{timeouts_r = TimeoutsR} = TransOpts, Timeout) -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{timeouts_r = [Timeout|TimeoutsR]}). + +%% Do the state transition +loop_event_done( + Parent, ?not_sys_debug, + #state{postponed = P} = S, + Events, Event, NextState, NewData, + #trans_opts{ + postpone = Postpone, hibernate = Hibernate, + timeouts_r = [], next_events_r = []}) -> + %% + %% Optimize the simple cases + %% i.e no timer changes, no inserted events and no debug, + %% by duplicate stripped down code + %% + %% Fast path + %% + case Postpone of + true -> + loop_event_done_fast( + Parent, Hibernate, + S, + Events, [Event|P], NextState, NewData); + false -> + loop_event_done_fast( + Parent, Hibernate, + S, + Events, P, NextState, NewData) + end; +loop_event_done( Parent, Debug_0, - #{state := State, postponed := P_0, - timer_refs := TimerRefs_0, timer_types := TimerTypes_0, - cancel_timers := CancelTimers_0} = S_0, + #state{ + state = State, postponed = P_0, + timer_refs = TimerRefs_0, timer_types = TimerTypes_0, + cancel_timers = CancelTimers_0} = S, Events_0, Event_0, NextState, NewData, - Hibernate, TimeoutsR, Postpone, NextEventsR) -> + #trans_opts{ + hibernate = Hibernate, timeouts_r = TimeoutsR, + postpone = Postpone, next_events_r = NextEventsR}) -> %% %% All options have been collected and next_events are buffered. %% Do the actual state transition. %% - {Debug_1,P_1} = % Move current event to postponed if Postpone + %% Full feature path + %% + [Debug_1|P_1] = % Move current event to postponed if Postpone case Postpone of true -> - {sys_debug(Debug_0, S_0, State, {postpone,Event_0,State}), - [Event_0|P_0]}; + [?sys_debug( + Debug_0, + {S#state.name,State}, + {postpone,Event_0,State}), + Event_0|P_0]; false -> - {sys_debug(Debug_0, S_0, State, {consume,Event_0,State}), - P_0} + [?sys_debug( + Debug_0, + {S#state.name,State}, + {consume,Event_0,State})|P_0] end, - {Events_1,P_2,{TimerTypes_1,CancelTimers_1}} = - %% Move all postponed events to queue and cancel the - %% state timeout if the state changes + {Events_2,P_2,Timers_2} = + %% Move all postponed events to queue, + %% cancel the event timer, + %% and cancel the state timeout if the state changes if NextState =:= State -> - {Events_0,P_1,{TimerTypes_0,CancelTimers_0}}; + {Events_0,P_1, + cancel_timer_by_type( + timeout, {TimerTypes_0,CancelTimers_0})}; true -> {lists:reverse(P_1, Events_0), [], cancel_timer_by_type( - state_timeout, TimerTypes_0, CancelTimers_0)} - %% The state timer is removed from TimerTypes_1 - %% but remains in TimerRefs_0 until we get + state_timeout, + cancel_timer_by_type( + timeout, {TimerTypes_0,CancelTimers_0}))} + %% The state timer is removed from TimerTypes + %% but remains in TimerRefs until we get %% the cancel_timer msg end, - {TimerRefs_2,TimerTypes_2,CancelTimers_2,TimeoutEvents} = - %% Stop and start non-event timers - parse_timers(TimerRefs_0, TimerTypes_1, CancelTimers_1, TimeoutsR), + {TimerRefs_3,{TimerTypes_3,CancelTimers_3},TimeoutEvents} = + %% Stop and start timers + parse_timers(TimerRefs_0, Timers_2, TimeoutsR), %% Place next events last in reversed queue - Events_2R = lists:reverse(Events_1, NextEventsR), - %% Enqueue immediate timeout events and start event timer - Events_3R = prepend_timeout_events(TimeoutEvents, Events_2R), - S_1 = - S_0#{ - state := NextState, - data := NewData, - postponed := P_2, - timer_refs := TimerRefs_2, - timer_types := TimerTypes_2, - cancel_timers := CancelTimers_2, - hibernate := Hibernate}, - case lists:reverse(Events_3R) of - [] -> - %% Get a new event - loop(Parent, Debug_1, S_1); - [Event|Events] -> + Events_3R = lists:reverse(Events_2, NextEventsR), + %% Enqueue immediate timeout events + Events_4R = prepend_timeout_events(TimeoutEvents, Events_3R), + loop_event_done( + Parent, Debug_1, + S#state{ + state = NextState, + data = NewData, + postponed = P_2, + timer_refs = TimerRefs_3, + timer_types = TimerTypes_3, + cancel_timers = CancelTimers_3, + hibernate = Hibernate}, + lists:reverse(Events_4R)). + +%% Fast path +%% +loop_event_done_fast( + Parent, Hibernate, + #state{ + state = NextState, + timer_types = #{timeout := _} = TimerTypes, + cancel_timers = CancelTimers} = S, + Events, P, NextState, NewData) -> + %% + %% Same state, event timeout active + %% + loop_event_done_fast( + Parent, Hibernate, S, + Events, P, NextState, NewData, + cancel_timer_by_type( + timeout, {TimerTypes,CancelTimers})); +loop_event_done_fast( + Parent, Hibernate, + #state{state = NextState} = S, + Events, P, NextState, NewData) -> + %% + %% Same state + %% + loop_event_done( + Parent, ?not_sys_debug, + S#state{ + data = NewData, + postponed = P, + hibernate = Hibernate}, + Events); +loop_event_done_fast( + Parent, Hibernate, + #state{ + timer_types = #{timeout := _} = TimerTypes, + cancel_timers = CancelTimers} = S, + Events, P, NextState, NewData) -> + %% + %% State change, event timeout active + %% + loop_event_done_fast( + Parent, Hibernate, S, + lists:reverse(P, Events), [], NextState, NewData, + cancel_timer_by_type( + state_timeout, + cancel_timer_by_type( + timeout, {TimerTypes,CancelTimers}))); +loop_event_done_fast( + Parent, Hibernate, + #state{ + timer_types = #{state_timeout := _} = TimerTypes, + cancel_timers = CancelTimers} = S, + Events, P, NextState, NewData) -> + %% + %% State change, state timeout active + %% + loop_event_done_fast( + Parent, Hibernate, S, + lists:reverse(P, Events), [], NextState, NewData, + cancel_timer_by_type( + state_timeout, + cancel_timer_by_type( + timeout, {TimerTypes,CancelTimers}))); +loop_event_done_fast( + Parent, Hibernate, + #state{} = S, + Events, P, NextState, NewData) -> + %% + %% State change, no timeout to automatically cancel + %% + loop_event_done( + Parent, ?not_sys_debug, + S#state{ + state = NextState, + data = NewData, + postponed = [], + hibernate = Hibernate}, + lists:reverse(P, Events)). +%% +%% Fast path +%% +loop_event_done_fast( + Parent, Hibernate, S, + Events, P, NextState, NewData, + {TimerTypes,CancelTimers}) -> + %% + loop_event_done( + Parent, ?not_sys_debug, + S#state{ + state = NextState, + data = NewData, + postponed = P, + timer_types = TimerTypes, + cancel_timers = CancelTimers, + hibernate = Hibernate}, + Events). + +loop_event_done(Parent, Debug, S, Q) -> + case Q of + [] -> + %% Get a new event + loop(Parent, Debug, S); + [{Type,Content}|Events] -> %% Loop until out of enqueued events - loop_event(Parent, Debug_1, S_1, Events, Event, Hibernate) + loop_event(Parent, Debug, S, Events, Type, Content) end. %%--------------------------------------------------------------------------- %% Server loop helpers -call_callback_mode(#{module := Module} = S) -> +call_callback_mode(#state{module = Module} = S) -> try Module:callback_mode() of CallbackMode -> callback_mode_result(S, CallbackMode) @@ -1179,58 +1585,45 @@ call_callback_mode(#{module := Module} = S) -> CallbackMode -> callback_mode_result(S, CallbackMode); Class:Reason -> - {Class,Reason,erlang:get_stacktrace()} + [Class,Reason,erlang:get_stacktrace()] end. callback_mode_result(S, CallbackMode) -> - case - parse_callback_mode( - if - is_atom(CallbackMode) -> - [CallbackMode]; - true -> - CallbackMode - end, undefined, false) - of - {undefined,_} -> - {error, - {bad_return_from_callback_mode,CallbackMode}, - ?STACKTRACE()}; - {CBMode,StateEnter} -> - {ok, - S#{ - callback_mode := CBMode, - state_enter := StateEnter}} - end. - -parse_callback_mode([], CBMode, StateEnter) -> - {CBMode,StateEnter}; -parse_callback_mode([H|T], CBMode, StateEnter) -> + callback_mode_result( + S, CallbackMode, listify(CallbackMode), undefined, false). +%% +callback_mode_result(_S, CallbackMode, [], undefined, _StateEnter) -> + [error, + {bad_return_from_callback_mode,CallbackMode}, + ?STACKTRACE()]; +callback_mode_result(S, _CallbackMode, [], CBMode, StateEnter) -> + S#state{callback_mode = CBMode, state_enter = StateEnter}; +callback_mode_result(S, CallbackMode, [H|T], CBMode, StateEnter) -> case callback_mode(H) of true -> - parse_callback_mode(T, H, StateEnter); + callback_mode_result(S, CallbackMode, T, H, StateEnter); false -> - case H of - state_enter -> - parse_callback_mode(T, CBMode, true); - _ -> - {undefined,StateEnter} + case state_enter(H) of + true -> + callback_mode_result(S, CallbackMode, T, CBMode, true); + false -> + [error, + {bad_return_from_callback_mode,CallbackMode}, + ?STACKTRACE()] end - end; -parse_callback_mode(_, _CBMode, StateEnter) -> - {undefined,StateEnter}. + end. call_state_function( - #{callback_mode := undefined} = S, Type, Content, State, Data) -> + #state{callback_mode = undefined} = S, Type, Content, State, Data) -> case call_callback_mode(S) of - {ok,NewS} -> + #state{} = NewS -> call_state_function(NewS, Type, Content, State, Data); Error -> Error end; call_state_function( - #{callback_mode := CallbackMode, module := Module} = S, + #state{callback_mode = CallbackMode, module = Module} = S, Type, Content, State, Data) -> try case CallbackMode of @@ -1241,333 +1634,108 @@ call_state_function( end of Result -> - {ok,Result,S} + {Result,S} catch Result -> - {ok,Result,S}; + {Result,S}; Class:Reason -> - {Class,Reason,erlang:get_stacktrace()} - end. - - -%% Interpret all callback return variants -parse_event_result( - AllowStateChange, Debug, S, - Events, Event, State, Data, Result) -> - case Result of - stop -> - terminate( - exit, normal, ?STACKTRACE(), Debug, - S#{state := State, data := Data}, - [Event|Events]); - {stop,Reason} -> - terminate( - exit, Reason, ?STACKTRACE(), Debug, - S#{state := State, data := Data}, - [Event|Events]); - {stop,Reason,NewData} -> - terminate( - exit, Reason, ?STACKTRACE(), Debug, - S#{state := State, data := NewData}, - [Event|Events]); - %% - {stop_and_reply,Reason,Replies} -> - reply_then_terminate( - exit, Reason, ?STACKTRACE(), Debug, - S#{state := State, data := Data}, - [Event|Events], Replies); - {stop_and_reply,Reason,Replies,NewData} -> - reply_then_terminate( - exit, Reason, ?STACKTRACE(), Debug, - S#{state := State, data := NewData}, - [Event|Events], Replies); - %% - {next_state,State,NewData} -> - {State,NewData,[],false}; - {next_state,NextState,NewData} when AllowStateChange -> - {NextState,NewData,[],true}; - {next_state,State,NewData,Actions} -> - {State,NewData,Actions,false}; - {next_state,NextState,NewData,Actions} when AllowStateChange -> - {NextState,NewData,Actions,true}; - %% - {keep_state,NewData} -> - {State,NewData,[],false}; - {keep_state,NewData,Actions} -> - {State,NewData,Actions,false}; - keep_state_and_data -> - {State,Data,[],false}; - {keep_state_and_data,Actions} -> - {State,Data,Actions,false}; - %% - {repeat_state,NewData} -> - {State,NewData,[],true}; - {repeat_state,NewData,Actions} -> - {State,NewData,Actions,true}; - repeat_state_and_data -> - {State,Data,[],true}; - {repeat_state_and_data,Actions} -> - {State,Data,Actions,true}; - %% - _ -> - terminate( - error, - {bad_return_from_state_function,Result}, - ?STACKTRACE(), Debug, - S#{state := State, data := Data}, - [Event|Events]) - end. - - -parse_enter_actions(Debug, S, State, Actions, Hibernate, TimeoutsR) -> - Postpone = forbidden, - NextEventsR = forbidden, - parse_actions( - Debug, S, State, listify(Actions), - Hibernate, TimeoutsR, Postpone, NextEventsR). - -parse_actions(Debug, S, State, Actions) -> - Hibernate = false, - TimeoutsR = [infinity], %% Will cancel event timer - Postpone = false, - NextEventsR = [], - parse_actions( - Debug, S, State, listify(Actions), - Hibernate, TimeoutsR, Postpone, NextEventsR). -%% -parse_actions( - Debug, _S, _State, [], - Hibernate, TimeoutsR, Postpone, NextEventsR) -> - {ok,Debug,Hibernate,TimeoutsR,Postpone,NextEventsR}; -parse_actions( - Debug, S, State, [Action|Actions], - Hibernate, TimeoutsR, Postpone, NextEventsR) -> - case Action of - %% Actual actions - {reply,From,Reply} -> - case from(From) of - true -> - NewDebug = do_reply(Debug, S, State, From, Reply), - parse_actions( - NewDebug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR); - false -> - {error, - {bad_action_from_state_function,Action}, - ?STACKTRACE()} - end; - %% - %% Actions that set options - {hibernate,NewHibernate} when is_boolean(NewHibernate) -> - parse_actions( - Debug, S, State, Actions, - NewHibernate, TimeoutsR, Postpone, NextEventsR); - hibernate -> - NewHibernate = true, - parse_actions( - Debug, S, State, Actions, - NewHibernate, TimeoutsR, Postpone, NextEventsR); - %% - {postpone,NewPostpone} - when is_boolean(NewPostpone), Postpone =/= forbidden -> - parse_actions( - Debug, S, State, Actions, - Hibernate, TimeoutsR, NewPostpone, NextEventsR); - postpone when Postpone =/= forbidden -> - NewPostpone = true, - parse_actions( - Debug, S, State, Actions, - Hibernate, TimeoutsR, NewPostpone, NextEventsR); - %% - {next_event,Type,Content} -> - case event_type(Type) of - true when NextEventsR =/= forbidden -> - NewDebug = - sys_debug(Debug, S, State, {in,{Type,Content}}), - parse_actions( - NewDebug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, - [{Type,Content}|NextEventsR]); - _ -> - {error, - {bad_action_from_state_function,Action}, - ?STACKTRACE()} - end; - %% - {{timeout,_},_,_} = Timeout -> - parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout); - {{timeout,_},_,_,_} = Timeout -> - parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout); - {timeout,_,_} = Timeout -> - parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout); - {timeout,_,_,_} = Timeout -> - parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout); - {state_timeout,_,_} = Timeout -> - parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout); - {state_timeout,_,_,_} = Timeout -> - parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout); - Time -> - parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Time) + [Class,Reason,erlang:get_stacktrace()] end. -parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout) -> - case Timeout of - {TimerType,Time,TimerMsg,TimerOpts} -> - case validate_timer_args(Time, listify(TimerOpts)) of - true -> - parse_actions( - Debug, S, State, Actions, - Hibernate, [Timeout|TimeoutsR], - Postpone, NextEventsR); - false -> - NewTimeout = {TimerType,Time,TimerMsg}, - parse_actions( - Debug, S, State, Actions, - Hibernate, [NewTimeout|TimeoutsR], - Postpone, NextEventsR); - error -> - {error, - {bad_action_from_state_function,Timeout}, - ?STACKTRACE()} - end; - {_,Time,_} -> - case validate_timer_args(Time, []) of - false -> - parse_actions( - Debug, S, State, Actions, - Hibernate, [Timeout|TimeoutsR], - Postpone, NextEventsR); - error -> - {error, - {bad_action_from_state_function,Timeout}, - ?STACKTRACE()} - end; - Time -> - case validate_timer_args(Time, []) of - false -> - parse_actions( - Debug, S, State, Actions, - Hibernate, [Timeout|TimeoutsR], - Postpone, NextEventsR); - error -> - {error, - {bad_action_from_state_function,Timeout}, - ?STACKTRACE()} - end - end. -validate_timer_args(Time, Opts) -> - validate_timer_args(Time, Opts, false). +%% -> absolute | relative | badarg +classify_timer(Time, Opts) -> + classify_timer(Time, Opts, false). %% -validate_timer_args(Time, [], true) when is_integer(Time) -> - true; -validate_timer_args(Time, [], false) when is_integer(Time), Time >= 0 -> - false; -validate_timer_args(infinity, [], Abs) -> - Abs; -validate_timer_args(Time, [{abs,Abs}|Opts], _) when is_boolean(Abs) -> - validate_timer_args(Time, Opts, Abs); -validate_timer_args(_, [_|_], _) -> - error. +classify_timer(Time, [], Abs) -> + case Abs of + true when + is_integer(Time); + Time =:= infinity -> + absolute; + false when + is_integer(Time), 0 =< Time; + Time =:= infinity -> + relative; + _ -> + badarg + end; +classify_timer(Time, [{abs,Abs}|Opts], _) when is_boolean(Abs) -> + classify_timer(Time, Opts, Abs); +classify_timer(_, Opts, _) when is_list(Opts) -> + badarg. %% Stop and start timers as well as create timeout zero events %% and pending event timer %% %% Stop and start timers non-event timers -parse_timers(TimerRefs, TimerTypes, CancelTimers, TimeoutsR) -> - parse_timers(TimerRefs, TimerTypes, CancelTimers, TimeoutsR, #{}, []). +parse_timers(TimerRefs, Timers, TimeoutsR) -> + parse_timers(TimerRefs, Timers, TimeoutsR, #{}, []). %% parse_timers( - TimerRefs, TimerTypes, CancelTimers, [], _Seen, TimeoutEvents) -> - {TimerRefs,TimerTypes,CancelTimers,TimeoutEvents}; + TimerRefs, Timers, [], _Seen, TimeoutEvents) -> + %% + {TimerRefs,Timers,TimeoutEvents}; parse_timers( - TimerRefs, TimerTypes, CancelTimers, [Timeout|TimeoutsR], - Seen, TimeoutEvents) -> + TimerRefs, Timers, [Timeout|TimeoutsR], Seen, TimeoutEvents) -> + %% case Timeout of {TimerType,Time,TimerMsg,TimerOpts} -> %% Absolute timer parse_timers( - TimerRefs, TimerTypes, CancelTimers, TimeoutsR, - Seen, TimeoutEvents, + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, TimerType, Time, TimerMsg, listify(TimerOpts)); %% Relative timers below {TimerType,0,TimerMsg} -> parse_timers( - TimerRefs, TimerTypes, CancelTimers, TimeoutsR, - Seen, TimeoutEvents, + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, TimerType, zero, TimerMsg, []); {TimerType,Time,TimerMsg} -> parse_timers( - TimerRefs, TimerTypes, CancelTimers, TimeoutsR, - Seen, TimeoutEvents, + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, TimerType, Time, TimerMsg, []); 0 -> parse_timers( - TimerRefs, TimerTypes, CancelTimers, TimeoutsR, - Seen, TimeoutEvents, + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, timeout, zero, 0, []); Time -> parse_timers( - TimerRefs, TimerTypes, CancelTimers, TimeoutsR, - Seen, TimeoutEvents, + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, timeout, Time, Time, []) end. parse_timers( - TimerRefs, TimerTypes, CancelTimers, TimeoutsR, - Seen, TimeoutEvents, + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, TimerType, Time, TimerMsg, TimerOpts) -> case Seen of #{TimerType := _} -> %% Type seen before - ignore parse_timers( - TimerRefs, TimerTypes, CancelTimers, TimeoutsR, - Seen, TimeoutEvents); + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents); #{} -> %% Unseen type - handle NewSeen = Seen#{TimerType => true}, case Time of infinity -> %% Cancel any running timer - {NewTimerTypes,NewCancelTimers} = - cancel_timer_by_type( - TimerType, TimerTypes, CancelTimers), parse_timers( - TimerRefs, NewTimerTypes, NewCancelTimers, TimeoutsR, - NewSeen, TimeoutEvents); + TimerRefs, cancel_timer_by_type(TimerType, Timers), + TimeoutsR, NewSeen, TimeoutEvents); zero -> %% Cancel any running timer - {NewTimerTypes,NewCancelTimers} = - cancel_timer_by_type( - TimerType, TimerTypes, CancelTimers), %% Handle zero time timeouts later - TimeoutEvent = {TimerType,TimerMsg}, parse_timers( - TimerRefs, NewTimerTypes, NewCancelTimers, TimeoutsR, - NewSeen, [TimeoutEvent|TimeoutEvents]); + TimerRefs, cancel_timer_by_type(TimerType, Timers), + TimeoutsR, NewSeen, + [{TimerType,TimerMsg}|TimeoutEvents]); _ -> %% (Re)start the timer TimerRef = erlang:start_timer( Time, self(), TimerMsg, TimerOpts), - case TimerTypes of - #{TimerType := OldTimerRef} -> + case Timers of + {#{TimerType := OldTimerRef} = TimerTypes, + CancelTimers} -> %% Cancel the running timer cancel_timer(OldTimerRef), NewCancelTimers = CancelTimers + 1, @@ -1575,17 +1743,17 @@ parse_timers( %% both TimerRefs and TimerTypes parse_timers( TimerRefs#{TimerRef => TimerType}, - TimerTypes#{TimerType => TimerRef}, - NewCancelTimers, TimeoutsR, - NewSeen, TimeoutEvents); - #{} -> + {TimerTypes#{TimerType => TimerRef}, + NewCancelTimers}, + TimeoutsR, NewSeen, TimeoutEvents); + {#{} = TimerTypes,CancelTimers} -> %% Insert the new timer into %% both TimerRefs and TimerTypes parse_timers( TimerRefs#{TimerRef => TimerType}, - TimerTypes#{TimerType => TimerRef}, - CancelTimers, TimeoutsR, - NewSeen, TimeoutEvents) + {TimerTypes#{TimerType => TimerRef}, + CancelTimers}, + TimeoutsR, NewSeen, TimeoutEvents) end end end. @@ -1607,6 +1775,8 @@ prepend_timeout_events([], EventsR) -> prepend_timeout_events([{timeout,_} = TimeoutEvent|TimeoutEvents], []) -> prepend_timeout_events(TimeoutEvents, [TimeoutEvent]); prepend_timeout_events([{timeout,_}|TimeoutEvents], EventsR) -> + %% Ignore since there are other events in queue + %% so they have cancelled the event timeout 0. prepend_timeout_events(TimeoutEvents, EventsR); prepend_timeout_events([TimeoutEvent|TimeoutEvents], EventsR) -> %% Just prepend all others @@ -1617,23 +1787,28 @@ prepend_timeout_events([TimeoutEvent|TimeoutEvents], EventsR) -> %%--------------------------------------------------------------------------- %% Server helpers -reply_then_terminate( - Class, Reason, Stacktrace, Debug, - #{state := State} = S, Q, Replies) -> +reply_then_terminate(Class, Reason, Stacktrace, Debug, S, Q, Replies) -> do_reply_then_terminate( - Class, Reason, Stacktrace, Debug, - S, Q, listify(Replies), State). + Class, Reason, Stacktrace, Debug, S, Q, listify(Replies)). %% do_reply_then_terminate( - Class, Reason, Stacktrace, Debug, S, Q, [], _State) -> + Class, Reason, Stacktrace, Debug, S, Q, []) -> terminate(Class, Reason, Stacktrace, Debug, S, Q); do_reply_then_terminate( - Class, Reason, Stacktrace, Debug, S, Q, [R|Rs], State) -> + Class, Reason, Stacktrace, Debug, S, Q, [R|Rs]) -> case R of {reply,{_To,_Tag}=From,Reply} -> - NewDebug = do_reply(Debug, S, State, From, Reply), + reply(From, Reply), + NewDebug = + ?sys_debug( + Debug, + begin + #state{name = Name, state = State} = S, + {Name,State} + end, + {out,Reply,From}), do_reply_then_terminate( - Class, Reason, Stacktrace, NewDebug, S, Q, Rs, State); + Class, Reason, Stacktrace, NewDebug, S, Q, Rs); _ -> terminate( error, @@ -1642,14 +1817,9 @@ do_reply_then_terminate( Debug, S, Q) end. -do_reply(Debug, S, State, From, Reply) -> - reply(From, Reply), - sys_debug(Debug, S, State, {out,Reply,From}). - - terminate( Class, Reason, Stacktrace, Debug, - #{module := Module, state := State, data := Data, postponed := P} = S, + #state{module = Module, state = State, data = Data} = S, Q) -> case erlang:function_exported(Module, terminate, 3) of true -> @@ -1660,7 +1830,7 @@ terminate( C:R -> ST = erlang:get_stacktrace(), error_info( - C, R, ST, S, Q, P, + C, R, ST, S, Q, format_status(terminate, get(), S)), sys:print_log(Debug), erlang:raise(C, R, ST) @@ -1671,14 +1841,14 @@ terminate( _ = case Reason of normal -> - sys_debug(Debug, S, State, {terminate,Reason}); + terminate_sys_debug(Debug, S, State, Reason); shutdown -> - sys_debug(Debug, S, State, {terminate,Reason}); + terminate_sys_debug(Debug, S, State, Reason); {shutdown,_} -> - sys_debug(Debug, S, State, {terminate,Reason}); + terminate_sys_debug(Debug, S, State, Reason); _ -> error_info( - Class, Reason, Stacktrace, S, Q, P, + Class, Reason, Stacktrace, S, Q, format_status(terminate, get(), S)), sys:print_log(Debug) end, @@ -1689,12 +1859,18 @@ terminate( erlang:raise(Class, Reason, Stacktrace) end. +terminate_sys_debug(Debug, S, State, Reason) -> + ?sys_debug(Debug, {S#state.name,State}, {terminate,Reason}). + + error_info( Class, Reason, Stacktrace, - #{name := Name, - callback_mode := CallbackMode, - state_enter := StateEnter}, - Q, P, FmtData) -> + #state{ + name = Name, + callback_mode = CallbackMode, + state_enter = StateEnter, + postponed = P}, + Q, FmtData) -> {FixedReason,FixedStacktrace} = case Stacktrace of [{M,F,Args,_}|ST] @@ -1775,7 +1951,7 @@ error_info( %% Call Module:format_status/2 or return a default value format_status( Opt, PDict, - #{module := Module, state := State, data := Data}) -> + #state{module = Module, state = State, data = Data}) -> case erlang:function_exported(Module, format_status, 2) of true -> try Module:format_status(Opt, [PDict,State,Data]) @@ -1800,6 +1976,7 @@ format_status_default(Opt, State, Data) -> [{data,[{"State",StateData}]}] end. +-compile({inline, [listify/1]}). listify(Item) when is_list(Item) -> Item; listify(Item) -> @@ -1813,14 +1990,16 @@ listify(Item) -> %% %% Remove the timer from TimerTypes. %% When we get the cancel_timer msg we remove it from TimerRefs. -cancel_timer_by_type(TimerType, TimerTypes, CancelTimers) -> +-compile({inline, [cancel_timer_by_type/2]}). +cancel_timer_by_type(TimerType, {TimerTypes,CancelTimers} = TT_CT) -> case TimerTypes of #{TimerType := TimerRef} -> - cancel_timer(TimerRef), + ok = erlang:cancel_timer(TimerRef, [{async,true}]), {maps:remove(TimerType, TimerTypes),CancelTimers + 1}; #{} -> - {TimerTypes,CancelTimers} + TT_CT end. +-compile({inline, [cancel_timer/1]}). cancel_timer(TimerRef) -> ok = erlang:cancel_timer(TimerRef, [{async,true}]). diff --git a/lib/stdlib/src/io_lib.erl b/lib/stdlib/src/io_lib.erl index 9d447418f8..cacd9f2524 100644 --- a/lib/stdlib/src/io_lib.erl +++ b/lib/stdlib/src/io_lib.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -149,7 +149,7 @@ fread(Chars, Format) -> -spec fread(Continuation, CharSpec, Format) -> Return when Continuation :: continuation() | [], - CharSpec :: string() | eof, + CharSpec :: string() | 'eof', Format :: string(), Return :: {'more', Continuation1 :: continuation()} | {'done', Result, LeftOverChars :: string()}, @@ -963,7 +963,18 @@ limit_tail(Other, D) -> %% maps:from_list() creates a map with the same internal ordering of %% the selected associations as in Map. limit_map(Map, D) -> - maps:from_list(erts_internal:maps_to_list(Map, D)). + limit_map(maps:iterator(Map), D, []). + +limit_map(_I, 0, Acc) -> + maps:from_list(Acc); +limit_map(I, D, Acc) -> + case maps:next(I) of + {K, V, NextI} -> + limit_map(NextI, D-1, [{K,V} | Acc]); + none -> + maps:from_list(Acc) + end. + %% maps:from_list(limit_map_body(erts_internal:maps_to_list(Map, D), D)). %% limit_map_body(_, 0) -> [{'...', '...'}]; diff --git a/lib/stdlib/src/io_lib_fread.erl b/lib/stdlib/src/io_lib_fread.erl index 983e8d4566..319bff484e 100644 --- a/lib/stdlib/src/io_lib_fread.erl +++ b/lib/stdlib/src/io_lib_fread.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -38,7 +38,7 @@ -spec fread(Continuation, String, Format) -> Return when Continuation :: io_lib:continuation() | [], - String :: string(), + String :: string() | 'eof', Format :: string(), Return :: {'more', Continuation1 :: io_lib:continuation()} | {'done', Result, LeftOverChars :: string()}, diff --git a/lib/stdlib/src/io_lib_pretty.erl b/lib/stdlib/src/io_lib_pretty.erl index 505613b80e..89e1931d2d 100644 --- a/lib/stdlib/src/io_lib_pretty.erl +++ b/lib/stdlib/src/io_lib_pretty.erl @@ -478,9 +478,19 @@ print_length(Term, _D, _RF, _Enc, _Str) -> print_length_map(_Map, 1, _RF, _Enc, _Str) -> {"#{...}", 6}; print_length_map(Map, D, RF, Enc, Str) when is_map(Map) -> - Pairs = print_length_map_pairs(erts_internal:maps_to_list(Map, D), D, RF, Enc, Str), + Pairs = print_length_map_pairs(limit_map(maps:iterator(Map), D, []), D, RF, Enc, Str), {{map, Pairs}, list_length(Pairs, 3)}. +limit_map(_I, 0, Acc) -> + Acc; +limit_map(I, D, Acc) -> + case maps:next(I) of + {K, V, NextI} -> + limit_map(NextI, D-1, [{K,V} | Acc]); + none -> + Acc + end. + print_length_map_pairs([], _D, _RF, _Enc, _Str) -> []; print_length_map_pairs(_Pairs, 1, _RF, _Enc, _Str) -> diff --git a/lib/stdlib/src/lib.erl b/lib/stdlib/src/lib.erl index a7980cc294..51e0c3f77e 100644 --- a/lib/stdlib/src/lib.erl +++ b/lib/stdlib/src/lib.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -551,7 +551,7 @@ format_stacktrace1(S0, Stack0, PF, SF, Enc) -> format_stacktrace2(S, Stack, 1, PF, Enc). format_stacktrace2(S, [{M,F,A,L}|Fs], N, PF, Enc) when is_integer(A) -> - [io_lib:fwrite(<<"~s~s ~ts ~s">>, + [io_lib:fwrite(<<"~s~s ~ts ~ts">>, [sep(N, S), origin(N, M, F, A), mfa_to_string(M, F, A, Enc), location(L)]) @@ -573,7 +573,7 @@ location(L) -> Line = proplists:get_value(line, L), if File =/= undefined, Line =/= undefined -> - io_lib:format("(~s, line ~w)", [File, Line]); + io_lib:format("(~ts, line ~w)", [File, Line]); true -> "" end. diff --git a/lib/stdlib/src/maps.erl b/lib/stdlib/src/maps.erl index 5dafdb282a..a13f340709 100644 --- a/lib/stdlib/src/maps.erl +++ b/lib/stdlib/src/maps.erl @@ -23,7 +23,8 @@ -export([get/3, filter/2,fold/3, map/2, size/1, update_with/3, update_with/4, - without/2, with/2]). + without/2, with/2, + iterator/1, next/1]). %% BIFs -export([get/2, find/2, from_list/1, @@ -31,6 +32,15 @@ new/0, put/3, remove/2, take/2, to_list/1, update/3, values/1]). +-opaque iterator() :: {term(), term(), iterator()} + | none | nonempty_improper_list(integer(),map()). + +-export_type([iterator/0]). + +-dialyzer({no_improper_lists, iterator/1}). + +-define(IS_ITERATOR(I), is_tuple(I) andalso tuple_size(I) == 3; I == none; is_integer(hd(I)) andalso is_map(tl(I))). + %% Shadowed by erl_bif_types: maps:get/2 -spec get(Key,Map) -> Value when Key :: term(), @@ -39,7 +49,6 @@ get(_,_) -> erlang:nif_error(undef). - -spec find(Key,Map) -> {ok, Value} | error when Key :: term(), Map :: map(), @@ -114,14 +123,20 @@ remove(_,_) -> erlang:nif_error(undef). take(_,_) -> erlang:nif_error(undef). -%% Shadowed by erl_bif_types: maps:to_list/1 -spec to_list(Map) -> [{Key,Value}] when Map :: map(), Key :: term(), Value :: term(). -to_list(_) -> erlang:nif_error(undef). +to_list(Map) when is_map(Map) -> + to_list_internal(erts_internal:map_next(0, Map, [])); +to_list(Map) -> + erlang:error({badmap,Map},[Map]). +to_list_internal([Iter, Map | Acc]) when is_integer(Iter) -> + to_list_internal(erts_internal:map_next(Iter, Map, Acc)); +to_list_internal(Acc) -> + Acc. %% Shadowed by erl_bif_types: maps:update/3 -spec update(Key,Value,Map1) -> Map2 when @@ -192,47 +207,80 @@ get(Key,Map,Default) -> erlang:error({badmap,Map},[Key,Map,Default]). --spec filter(Pred,Map1) -> Map2 when +-spec filter(Pred,MapOrIter) -> Map when Pred :: fun((Key, Value) -> boolean()), Key :: term(), Value :: term(), - Map1 :: map(), - Map2 :: map(). + MapOrIter :: map() | iterator(), + Map :: map(). filter(Pred,Map) when is_function(Pred,2), is_map(Map) -> - maps:from_list([{K,V}||{K,V}<-maps:to_list(Map),Pred(K,V)]); + maps:from_list(filter_1(Pred, iterator(Map))); +filter(Pred,Iterator) when is_function(Pred,2), ?IS_ITERATOR(Iterator) -> + maps:from_list(filter_1(Pred, Iterator)); filter(Pred,Map) -> erlang:error(error_type(Map),[Pred,Map]). - --spec fold(Fun,Init,Map) -> Acc when +filter_1(Pred, Iter) -> + case next(Iter) of + {K, V, NextIter} -> + case Pred(K,V) of + true -> + [{K,V} | filter_1(Pred, NextIter)]; + false -> + filter_1(Pred, NextIter) + end; + none -> + [] + end. + +-spec fold(Fun,Init,MapOrIter) -> Acc when Fun :: fun((K, V, AccIn) -> AccOut), Init :: term(), Acc :: term(), AccIn :: term(), AccOut :: term(), - Map :: map(), + MapOrIter :: map() | iterator(), K :: term(), V :: term(). fold(Fun,Init,Map) when is_function(Fun,3), is_map(Map) -> - lists:foldl(fun({K,V},A) -> Fun(K,V,A) end,Init,maps:to_list(Map)); + fold_1(Fun,Init,iterator(Map)); +fold(Fun,Init,Iterator) when is_function(Fun,3), ?IS_ITERATOR(Iterator) -> + fold_1(Fun,Init,Iterator); fold(Fun,Init,Map) -> erlang:error(error_type(Map),[Fun,Init,Map]). --spec map(Fun,Map1) -> Map2 when +fold_1(Fun, Acc, Iter) -> + case next(Iter) of + {K, V, NextIter} -> + fold_1(Fun, Fun(K,V,Acc), NextIter); + none -> + Acc + end. + +-spec map(Fun,MapOrIter) -> Map when Fun :: fun((K, V1) -> V2), - Map1 :: map(), - Map2 :: map(), + MapOrIter :: map() | iterator(), + Map :: map(), K :: term(), V1 :: term(), V2 :: term(). map(Fun,Map) when is_function(Fun, 2), is_map(Map) -> - maps:from_list([{K,Fun(K,V)}||{K,V}<-maps:to_list(Map)]); + maps:from_list(map_1(Fun, iterator(Map))); +map(Fun,Iterator) when is_function(Fun, 2), ?IS_ITERATOR(Iterator) -> + maps:from_list(map_1(Fun, Iterator)); map(Fun,Map) -> erlang:error(error_type(Map),[Fun,Map]). +map_1(Fun, Iter) -> + case next(Iter) of + {K, V, NextIter} -> + [{K, Fun(K, V)} | map_1(Fun, NextIter)]; + none -> + [] + end. -spec size(Map) -> non_neg_integer() when Map :: map(). @@ -242,6 +290,26 @@ size(Map) when is_map(Map) -> size(Val) -> erlang:error({badmap,Val},[Val]). +-spec iterator(Map) -> Iterator when + Map :: map(), + Iterator :: iterator(). + +iterator(M) when is_map(M) -> [0 | M]; +iterator(M) -> erlang:error({badmap, M}, [M]). + +-spec next(Iterator) -> {Key, Value, NextIterator} | 'none' when + Iterator :: iterator(), + Key :: term(), + Value :: term(), + NextIterator :: iterator(). +next({K, V, I}) -> + {K, V, I}; +next([Path | Map]) when is_integer(Path), is_map(Map) -> + erts_internal:map_next(Path, Map, iterator); +next(none) -> + none; +next(Iter) -> + erlang:error(badarg, [Iter]). -spec without(Ks,Map1) -> Map2 when Ks :: [K], @@ -250,11 +318,10 @@ size(Val) -> K :: term(). without(Ks,M) when is_list(Ks), is_map(M) -> - lists:foldl(fun(K, M1) -> ?MODULE:remove(K, M1) end, M, Ks); + lists:foldl(fun(K, M1) -> maps:remove(K, M1) end, M, Ks); without(Ks,M) -> erlang:error(error_type(M),[Ks,M]). - -spec with(Ks, Map1) -> Map2 when Ks :: [K], Map1 :: map(), @@ -263,17 +330,17 @@ without(Ks,M) -> with(Ks,Map1) when is_list(Ks), is_map(Map1) -> Fun = fun(K, List) -> - case ?MODULE:find(K, Map1) of - {ok, V} -> - [{K, V} | List]; - error -> - List - end - end, - ?MODULE:from_list(lists:foldl(Fun, [], Ks)); + case maps:find(K, Map1) of + {ok, V} -> + [{K, V} | List]; + error -> + List + end + end, + maps:from_list(lists:foldl(Fun, [], Ks)); with(Ks,M) -> erlang:error(error_type(M),[Ks,M]). -error_type(M) when is_map(M) -> badarg; +error_type(M) when is_map(M); ?IS_ITERATOR(M) -> badarg; error_type(V) -> {badmap, V}. diff --git a/lib/stdlib/src/shell.erl b/lib/stdlib/src/shell.erl index 212b143b1d..ad4984b64c 100644 --- a/lib/stdlib/src/shell.erl +++ b/lib/stdlib/src/shell.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -701,7 +701,9 @@ exprs([E0|Es], Bs1, RT, Lf, Ef, Bs0, W) -> {W,V0}; true -> case result_will_be_saved() of true -> V0; - false -> ignored + false -> + erlang:garbage_collect(), + ignored end end, {{value,V,Bs,get()},Bs}; diff --git a/lib/stdlib/src/stdlib.app.src b/lib/stdlib/src/stdlib.app.src index ab0824ca17..5fb48acfab 100644 --- a/lib/stdlib/src/stdlib.app.src +++ b/lib/stdlib/src/stdlib.app.src @@ -101,6 +101,7 @@ timer, unicode, unicode_util, + uri_string, win32reg, zip]}, {registered,[timer_server,rsh_starter,take_over_monitor,pool_master, diff --git a/lib/stdlib/src/string.erl b/lib/stdlib/src/string.erl index 5a4d2df2a6..e01bb7d85e 100644 --- a/lib/stdlib/src/string.erl +++ b/lib/stdlib/src/string.erl @@ -74,15 +74,16 @@ -export([to_upper/1, to_lower/1]). %% -import(lists,[member/2]). - -compile({no_auto_import,[length/1]}). +-compile({inline, [btoken/2, rev/1, append/2, stack/2, search_compile/1]}). +-define(ASCII_LIST(CP1,CP2), CP1 < 256, CP2 < 256, CP1 =/= $\r). -export_type([grapheme_cluster/0]). -type grapheme_cluster() :: char() | [char()]. -type direction() :: 'leading' | 'trailing'. --dialyzer({no_improper_lists, stack/2}). +-dialyzer({no_improper_lists, [stack/2, length_b/3]}). %%% BIFs internal (not documented) should not to be used outside of this module %%% May be removed -export([list_to_float/1, list_to_integer/1]). @@ -127,8 +128,10 @@ is_empty(_) -> false. %% Count the number of grapheme clusters in chardata -spec length(String::unicode:chardata()) -> non_neg_integer(). +length(<<CP1/utf8, Bin/binary>>) -> + length_b(Bin, CP1, 0); length(CD) -> - length_1(unicode_util:gc(CD), 0). + length_1(CD, 0). %% Convert a string to a list of grapheme clusters -spec to_graphemes(String::unicode:chardata()) -> [grapheme_cluster()]. @@ -176,6 +179,8 @@ equal(A, B, true, Norm) -> %% Reverse grapheme clusters -spec reverse(String::unicode:chardata()) -> [grapheme_cluster()]. +reverse(<<CP1/utf8, Rest/binary>>) -> + reverse_b(Rest, CP1, []); reverse(CD) -> reverse_1(CD, []). @@ -186,7 +191,10 @@ reverse(CD) -> Start :: non_neg_integer(), Slice :: unicode:chardata(). slice(CD, N) when is_integer(N), N >= 0 -> - slice_l(CD, N, is_binary(CD)). + case slice_l0(CD, N) of + [] when is_binary(CD) -> <<>>; + Res -> Res + end. -spec slice(String, Start, Length) -> Slice when String::unicode:chardata(), @@ -195,9 +203,15 @@ slice(CD, N) when is_integer(N), N >= 0 -> Slice :: unicode:chardata(). slice(CD, N, Length) when is_integer(N), N >= 0, is_integer(Length), Length > 0 -> - slice_trail(slice_l(CD, N, is_binary(CD)), Length); + case slice_l0(CD, N) of + [] when is_binary(CD) -> <<>>; + L -> slice_trail(L, Length) + end; slice(CD, N, infinity) -> - slice_l(CD, N, is_binary(CD)); + case slice_l0(CD, N) of + [] when is_binary(CD) -> <<>>; + Res -> Res + end; slice(CD, _, 0) -> case is_binary(CD) of true -> <<>>; @@ -256,18 +270,22 @@ trim(Str, Dir) -> Dir :: direction() | 'both', Characters :: [grapheme_cluster()]. trim(Str, _, []) -> Str; +trim(Str, leading, [Sep]) when is_list(Str), Sep < 256 -> + trim_ls(Str, Sep); trim(Str, leading, Sep) when is_list(Sep) -> - trim_l(Str, search_pattern(Sep)); -trim(Str, trailing, Sep) when is_list(Sep) -> - trim_t(Str, 0, search_pattern(Sep)); -trim(Str, both, Sep0) when is_list(Sep0) -> - Sep = search_pattern(Sep0), - trim_t(trim_l(Str,Sep), 0, Sep). + trim_l(Str, Sep); +trim(Str, trailing, [Sep]) when is_list(Str), Sep < 256 -> + trim_ts(Str, Sep); +trim(Str, trailing, Seps0) when is_list(Seps0) -> + Seps = search_pattern(Seps0), + trim_t(Str, 0, Seps); +trim(Str, both, Sep) when is_list(Sep) -> + trim(trim(Str,leading,Sep), trailing, Sep). %% Delete trailing newlines or \r\n -spec chomp(String::unicode:chardata()) -> unicode:chardata(). chomp(Str) -> - trim_t(Str,0, {[[$\r,$\n],$\n], [$\r,$\n], [<<$\r>>,<<$\n>>]}). + trim(Str, trailing, [[$\r,$\n],$\n]). %% Split String into two parts where the leading part consists of Characters -spec take(String, Characters) -> {Leading, Trailing} when @@ -300,8 +318,7 @@ take(Str, [], Complement, Dir) -> {true, leading} -> {Str, Empty}; {true, trailing} -> {Empty, Str} end; -take(Str, Sep0, false, leading) -> - Sep = search_pattern(Sep0), +take(Str, Sep, false, leading) -> take_l(Str, Sep, []); take(Str, Sep0, true, leading) -> Sep = search_pattern(Sep0), @@ -461,6 +478,7 @@ replace(String, SearchPattern, Replacement, Where) -> SeparatorList::[grapheme_cluster()]) -> [unicode:chardata()]. lexemes([], _) -> []; +lexemes(Str, []) -> [Str]; lexemes(Str, Seps0) when is_list(Seps0) -> Seps = search_pattern(Seps0), lexemes_m(Str, Seps, []). @@ -494,13 +512,13 @@ find(String, SearchPattern, leading) -> find(String, SearchPattern, trailing) -> find_r(String, unicode:characters_to_list(SearchPattern), nomatch). -%% Fetch first codepoint and return rest in tail +%% Fetch first grapheme cluster and return rest in tail -spec next_grapheme(String::unicode:chardata()) -> maybe_improper_list(grapheme_cluster(),unicode:chardata()) | {error,unicode:chardata()}. next_grapheme(CD) -> unicode_util:gc(CD). -%% Fetch first grapheme cluster and return rest in tail +%% Fetch first codepoint and return rest in tail -spec next_codepoint(String::unicode:chardata()) -> maybe_improper_list(char(),unicode:chardata()) | {error,unicode:chardata()}. @@ -508,10 +526,23 @@ next_codepoint(CD) -> unicode_util:cp(CD). %% Internals -length_1([_|Rest], N) -> - length_1(unicode_util:gc(Rest), N+1); -length_1([], N) -> - N. +length_1([CP1|[CP2|_]=Cont], N) when ?ASCII_LIST(CP1,CP2) -> + length_1(Cont, N+1); +length_1(Str, N) -> + case unicode_util:gc(Str) of + [] -> N; + [_|Rest] -> length_1(Rest, N+1) + end. + +length_b(<<CP2/utf8, Rest/binary>>, CP1, N) + when ?ASCII_LIST(CP1,CP2) -> + length_b(Rest, CP2, N+1); +length_b(Bin0, CP1, N) -> + [_|Bin1] = unicode_util:gc([CP1|Bin0]), + case unicode_util:cp(Bin1) of + [] -> N+1; + [CP3|Bin] -> length_b(Bin, CP3, N+1) + end. equal_1([A|AR], [B|BR]) when is_integer(A), is_integer(B) -> A =:= B andalso equal_1(AR, BR); @@ -550,29 +581,66 @@ equal_norm_nocase(A0, B0, Norm) -> {L1,L2} when is_list(L1), is_list(L2) -> false end. +reverse_1([CP1|[CP2|_]=Cont], Acc) when ?ASCII_LIST(CP1,CP2) -> + reverse_1(Cont, [CP1|Acc]); reverse_1(CD, Acc) -> case unicode_util:gc(CD) of [GC|Rest] -> reverse_1(Rest, [GC|Acc]); [] -> Acc end. -slice_l(CD, N, Binary) when N > 0 -> +reverse_b(<<CP2/utf8, Rest/binary>>, CP1, Acc) + when ?ASCII_LIST(CP1,CP2) -> + reverse_b(Rest, CP2, [CP1|Acc]); +reverse_b(Bin0, CP1, Acc) -> + [GC|Bin1] = unicode_util:gc([CP1|Bin0]), + case unicode_util:cp(Bin1) of + [] -> [GC|Acc]; + [CP3|Bin] -> reverse_b(Bin, CP3, [GC|Acc]) + end. + +slice_l0(<<CP1/utf8, Bin/binary>>, N) when N > 0 -> + slice_lb(Bin, CP1, N); +slice_l0(L, N) -> + slice_l(L, N). + +slice_l([CP1|[CP2|_]=Cont], N) when ?ASCII_LIST(CP1,CP2),N > 0 -> + slice_l(Cont, N-1); +slice_l(CD, N) when N > 0 -> case unicode_util:gc(CD) of - [_|Cont] -> slice_l(Cont, N-1, Binary); - [] when Binary -> <<>>; + [_|Cont] -> slice_l(Cont, N-1); [] -> [] end; -slice_l(Cont, 0, Binary) -> - case is_empty(Cont) of - true when Binary -> <<>>; - _ -> Cont +slice_l(Cont, 0) -> + Cont. + +slice_lb(<<CP2/utf8, Bin/binary>>, CP1, N) when ?ASCII_LIST(CP1,CP2), N > 1 -> + slice_lb(Bin, CP2, N-1); +slice_lb(Bin, CP1, N) -> + [_|Rest] = unicode_util:gc([CP1|Bin]), + if N > 1 -> + case unicode_util:cp(Rest) of + [CP2|Cont] -> slice_lb(Cont, CP2, N-1); + [] -> <<>> + end; + N =:= 1 -> + Rest end. +slice_trail(Orig, N) when is_binary(Orig) -> + case Orig of + <<CP1/utf8, Bin/binary>> when N > 0 -> + Length = slice_bin(Bin, CP1, N), + Sz = byte_size(Orig) - Length, + <<Keep:Sz/binary, _/binary>> = Orig, + Keep; + _ -> <<>> + end; slice_trail(CD, N) when is_list(CD) -> - slice_list(CD, N); -slice_trail(CD, N) when is_binary(CD) -> - slice_bin(CD, N, CD). + slice_list(CD, N). +slice_list([CP1|[CP2|_]=Cont], N) when ?ASCII_LIST(CP1,CP2),N > 0 -> + [CP1|slice_list(Cont, N-1)]; slice_list(CD, N) when N > 0 -> case unicode_util:gc(CD) of [GC|Cont] -> append(GC, slice_list(Cont, N-1)); @@ -581,17 +649,16 @@ slice_list(CD, N) when N > 0 -> slice_list(_, 0) -> []. -slice_bin(CD, N, Orig) when N > 0 -> - case unicode_util:gc(CD) of - [_|Cont] -> slice_bin(Cont, N-1, Orig); - [] -> Orig +slice_bin(<<CP2/utf8, Bin/binary>>, CP1, N) when ?ASCII_LIST(CP1,CP2), N > 0 -> + slice_bin(Bin, CP2, N-1); +slice_bin(CD, CP1, N) when N > 0 -> + [_|Bin] = unicode_util:gc([CP1|CD]), + case unicode_util:cp(Bin) of + [CP2|Cont] -> slice_bin(Cont, CP2, N-1); + [] -> 0 end; -slice_bin([], 0, Orig) -> - Orig; -slice_bin(CD, 0, Orig) -> - Sz = byte_size(Orig) - byte_size(CD), - <<Keep:Sz/binary, _/binary>> = Orig, - Keep. +slice_bin(CD, CP1, 0) -> + byte_size(CD)+byte_size(<<CP1/utf8>>). uppercase_list(CPs0) -> case unicode_util:uppercase(CPs0) of @@ -641,16 +708,31 @@ casefold_bin(CPs0, Acc) -> [] -> Acc end. - +%% Fast path for ascii searching for one character in lists +trim_ls([CP1|[CP2|_]=Cont]=Str, Sep) + when ?ASCII_LIST(CP1,CP2) -> + case Sep of + CP1 -> trim_ls(Cont, Sep); + _ -> Str + end; +trim_ls(Str, Sep) -> + trim_l(Str, [Sep]). + +trim_l([CP1|[CP2|_]=Cont]=Str, Sep) + when ?ASCII_LIST(CP1,CP2) -> + case lists:member(CP1, Sep) of + true -> trim_l(Cont, Sep); + false -> Str + end; trim_l([Bin|Cont0], Sep) when is_binary(Bin) -> case bin_search_inv(Bin, Cont0, Sep) of {nomatch, Cont} -> trim_l(Cont, Sep); Keep -> Keep end; -trim_l(Str, {GCs, _, _}=Sep) when is_list(Str) -> +trim_l(Str, Sep) when is_list(Str) -> case unicode_util:gc(Str) of [C|Cs] -> - case lists:member(C, GCs) of + case lists:member(C, Sep) of true -> trim_l(Cs, Sep); false -> Str end; @@ -662,15 +744,51 @@ trim_l(Bin, Sep) when is_binary(Bin) -> [Keep] -> Keep end. -trim_t([Bin|Cont0], N, Sep) when is_binary(Bin) -> +%% Fast path for ascii searching for one character in lists +trim_ts([Sep|Cs1]=Str, Sep) -> + case Cs1 of + [] -> []; + [CP2|_] when ?ASCII_LIST(Sep,CP2) -> + Tail = trim_ts(Cs1, Sep), + case is_empty(Tail) of + true -> []; + false -> [Sep|Tail] + end; + _ -> + trim_t(Str, 0, search_pattern([Sep])) + end; +trim_ts([CP|Cont],Sep) when is_integer(CP) -> + [CP|trim_ts(Cont, Sep)]; +trim_ts(Str, Sep) -> + trim_t(Str, 0, search_pattern([Sep])). + +trim_t([CP1|Cont]=Cs0, _, {GCs,CPs,_}=Seps) when is_integer(CP1) -> + case lists:member(CP1, CPs) of + true -> + [GC|Cs1] = unicode_util:gc(Cs0), + case lists:member(GC, GCs) of + true -> + Tail = trim_t(Cs1, 0, Seps), + case is_empty(Tail) of + true -> []; + false -> append(GC,Tail) + end; + false -> + append(GC,trim_t(Cs1, 0, Seps)) + end; + false -> + [CP1|trim_t(Cont, 0, Seps)] + end; +trim_t([Bin|Cont0], N, {GCs,_,_}=Seps0) when is_binary(Bin) -> <<_:N/binary, Rest/binary>> = Bin, - case bin_search(Rest, Cont0, Sep) of + Seps = search_compile(Seps0), + case bin_search(Rest, Cont0, Seps) of {nomatch,_} -> - stack(Bin, trim_t(Cont0, 0, Sep)); + stack(Bin, trim_t(Cont0, 0, Seps)); [SepStart|Cont1] -> - case bin_search_inv(SepStart, Cont1, Sep) of + case bin_search_inv(SepStart, Cont1, GCs) of {nomatch, Cont} -> - Tail = trim_t(Cont, 0, Sep), + Tail = trim_t(Cont, 0, Seps), case is_empty(Tail) of true -> KeepSz = byte_size(Bin) - byte_size(SepStart), @@ -682,67 +800,69 @@ trim_t([Bin|Cont0], N, Sep) when is_binary(Bin) -> end; [NonSep|Cont] when is_binary(NonSep) -> KeepSz = byte_size(Bin) - byte_size(NonSep), - trim_t([Bin|Cont], KeepSz, Sep) + trim_t([Bin|Cont], KeepSz, Seps) end end; -trim_t(Str, 0, {GCs,CPs,_}=Sep) when is_list(Str) -> - case unicode_util:cp(Str) of - [CP|Cs] -> - case lists:member(CP, CPs) of +trim_t(Str, 0, {GCs,_,_}=Seps) when is_list(Str) -> + case unicode_util:gc(Str) of + [GC|Cs1] -> + case lists:member(GC, GCs) of true -> - [GC|Cs1] = unicode_util:gc(Str), - case lists:member(GC, GCs) of - true -> - Tail = trim_t(Cs1, 0, Sep), - case is_empty(Tail) of - true -> []; - false -> append(GC,Tail) - end; - false -> - append(GC,trim_t(Cs1, 0, Sep)) + Tail = trim_t(Cs1, 0, Seps), + case is_empty(Tail) of + true -> []; + false -> append(GC,Tail) end; false -> - append(CP,trim_t(Cs, 0, Sep)) + append(GC,trim_t(Cs1, 0, Seps)) end; [] -> [] end; -trim_t(Bin, N, Sep) when is_binary(Bin) -> +trim_t(Bin, N, {GCs,_,_}=Seps0) when is_binary(Bin) -> <<_:N/binary, Rest/binary>> = Bin, - case bin_search(Rest, Sep) of + Seps = search_compile(Seps0), + case bin_search(Rest, [], Seps) of {nomatch,_} -> Bin; [SepStart] -> - case bin_search_inv(SepStart, [], Sep) of + case bin_search_inv(SepStart, [], GCs) of {nomatch,_} -> KeepSz = byte_size(Bin) - byte_size(SepStart), <<Keep:KeepSz/binary, _/binary>> = Bin, Keep; [NonSep] -> KeepSz = byte_size(Bin) - byte_size(NonSep), - trim_t(Bin, KeepSz, Sep) + trim_t(Bin, KeepSz, Seps) end end. -take_l([Bin|Cont0], Sep, Acc) when is_binary(Bin) -> - case bin_search_inv(Bin, Cont0, Sep) of + +take_l([CP1|[CP2|_]=Cont]=Str, Seps, Acc) + when ?ASCII_LIST(CP1,CP2) -> + case lists:member(CP1, Seps) of + true -> take_l(Cont, Seps, [CP1|Acc]); + false -> {rev(Acc), Str} + end; +take_l([Bin|Cont0], Seps, Acc) when is_binary(Bin) -> + case bin_search_inv(Bin, Cont0, Seps) of {nomatch, Cont} -> Used = cp_prefix(Cont0, Cont), - take_l(Cont, Sep, [unicode:characters_to_binary([Bin|Used])|Acc]); + take_l(Cont, Seps, [unicode:characters_to_binary([Bin|Used])|Acc]); [Bin1|_]=After when is_binary(Bin1) -> First = byte_size(Bin) - byte_size(Bin1), <<Keep:First/binary, _/binary>> = Bin, {btoken(Keep,Acc), After} end; -take_l(Str, {GCs, _, _}=Sep, Acc) when is_list(Str) -> +take_l(Str, Seps, Acc) when is_list(Str) -> case unicode_util:gc(Str) of [C|Cs] -> - case lists:member(C, GCs) of - true -> take_l(Cs, Sep, append(rev(C),Acc)); + case lists:member(C, Seps) of + true -> take_l(Cs, Seps, append(rev(C),Acc)); false -> {rev(Acc), Str} end; [] -> {rev(Acc), []} end; -take_l(Bin, Sep, Acc) when is_binary(Bin) -> - case bin_search_inv(Bin, [], Sep) of +take_l(Bin, Seps, Acc) when is_binary(Bin) -> + case bin_search_inv(Bin, [], Seps) of {nomatch,_} -> {btoken(Bin, Acc), <<>>}; [After] -> @@ -751,27 +871,41 @@ take_l(Bin, Sep, Acc) when is_binary(Bin) -> {btoken(Keep, Acc), After} end. -take_lc([Bin|Cont0], Sep, Acc) when is_binary(Bin) -> - case bin_search(Bin, Cont0, Sep) of + +take_lc([CP1|Cont]=Str0, {GCs,CPs,_}=Seps, Acc) when is_integer(CP1) -> + case lists:member(CP1, CPs) of + true -> + [GC|Str] = unicode_util:gc(Str0), + case lists:member(GC, GCs) of + false -> take_lc(Str, Seps, append(rev(GC),Acc)); + true -> {rev(Acc), Str0} + end; + false -> + take_lc(Cont, Seps, append(CP1,Acc)) + end; +take_lc([Bin|Cont0], Seps0, Acc) when is_binary(Bin) -> + Seps = search_compile(Seps0), + case bin_search(Bin, Cont0, Seps) of {nomatch, Cont} -> Used = cp_prefix(Cont0, Cont), - take_lc(Cont, Sep, [unicode:characters_to_binary([Bin|Used])|Acc]); + take_lc(Cont, Seps, [unicode:characters_to_binary([Bin|Used])|Acc]); [Bin1|_]=After when is_binary(Bin1) -> First = byte_size(Bin) - byte_size(Bin1), <<Keep:First/binary, _/binary>> = Bin, {btoken(Keep,Acc), After} end; -take_lc(Str, {GCs, _, _}=Sep, Acc) when is_list(Str) -> +take_lc(Str, {GCs,_,_}=Seps, Acc) when is_list(Str) -> case unicode_util:gc(Str) of [C|Cs] -> case lists:member(C, GCs) of - false -> take_lc(Cs, Sep, append(rev(C),Acc)); + false -> take_lc(Cs, Seps, append(rev(C),Acc)); true -> {rev(Acc), Str} end; [] -> {rev(Acc), []} end; -take_lc(Bin, Sep, Acc) when is_binary(Bin) -> - case bin_search(Bin, [], Sep) of +take_lc(Bin, Seps0, Acc) when is_binary(Bin) -> + Seps = search_compile(Seps0), + case bin_search(Bin, [], Seps) of {nomatch,_} -> {btoken(Bin, Acc), <<>>}; [After] -> @@ -780,148 +914,192 @@ take_lc(Bin, Sep, Acc) when is_binary(Bin) -> {btoken(Keep, Acc), After} end. -take_t([Bin|Cont0], N, Sep) when is_binary(Bin) -> + +take_t([CP1|Cont]=Str0, _, {GCs,CPs,_}=Seps) when is_integer(CP1) -> + case lists:member(CP1, CPs) of + true -> + [GC|Str] = unicode_util:gc(Str0), + case lists:member(GC, GCs) of + true -> + {Head, Tail} = take_t(Str, 0, Seps), + case is_empty(Head) of + true -> {Head, append(GC,Tail)}; + false -> {append(GC,Head), Tail} + end; + false -> + {Head, Tail} = take_t(Str, 0, Seps), + {append(GC,Head), Tail} + end; + false -> + {Head, Tail} = take_t(Cont, 0, Seps), + {[CP1|Head], Tail} + end; +take_t([Bin|Cont0], N, {GCs,_,_}=Seps0) when is_binary(Bin) -> <<_:N/binary, Rest/binary>> = Bin, - case bin_search(Rest, Cont0, Sep) of + Seps = search_compile(Seps0), + case bin_search(Rest, Cont0, Seps) of {nomatch,Cont} -> Used = cp_prefix(Cont0, Cont), - {Head, Tail} = take_t(Cont, 0, Sep), + {Head, Tail} = take_t(Cont, 0, Seps), {stack(unicode:characters_to_binary([Bin|Used]), Head), Tail}; [SepStart|Cont1] -> - case bin_search_inv(SepStart, Cont1, Sep) of + case bin_search_inv(SepStart, Cont1, GCs) of {nomatch, Cont} -> - {Head, Tail} = take_t(Cont, 0, Sep), + {Head, Tail} = take_t(Cont, 0, Seps), Used = cp_prefix(Cont0, Cont), - case equal(Tail, Cont) of + case is_empty(Head) of true -> KeepSz = byte_size(Bin) - byte_size(SepStart), <<Keep:KeepSz/binary, End/binary>> = Bin, - {stack(Keep,Head), stack(stack(End,Used),Tail)}; + {Keep, stack(stack(End,Used),Tail)}; false -> {stack(unicode:characters_to_binary([Bin|Used]),Head), Tail} end; [NonSep|Cont] when is_binary(NonSep) -> KeepSz = byte_size(Bin) - byte_size(NonSep), - take_t([Bin|Cont], KeepSz, Sep) + take_t([Bin|Cont], KeepSz, Seps) end end; -take_t(Str, 0, {GCs,CPs,_}=Sep) when is_list(Str) -> - case unicode_util:cp(Str) of - [CP|Cs] -> - case lists:member(CP, CPs) of +take_t(Str, 0, {GCs,_,_}=Seps) when is_list(Str) -> + case unicode_util:gc(Str) of + [GC|Cs1] -> + case lists:member(GC, GCs) of true -> - [GC|Cs1] = unicode_util:gc(Str), - case lists:member(GC, GCs) of - true -> - {Head, Tail} = take_t(Cs1, 0, Sep), - case equal(Tail, Cs1) of - true -> {Head, append(GC,Tail)}; - false -> {append(GC,Head), Tail} - end; - false -> - {Head, Tail} = take_t(Cs, 0, Sep), - {append(CP,Head), Tail} + {Head, Tail} = take_t(Cs1, 0, Seps), + case is_empty(Head) of + true -> {Head, append(GC,Tail)}; + false -> {append(GC,Head), Tail} end; false -> - {Head, Tail} = take_t(Cs, 0, Sep), - {append(CP,Head), Tail} + {Head, Tail} = take_t(Cs1, 0, Seps), + {append(GC,Head), Tail} end; [] -> {[],[]} end; -take_t(Bin, N, Sep) when is_binary(Bin) -> +take_t(Bin, N, {GCs,_,_}=Seps0) when is_binary(Bin) -> <<_:N/binary, Rest/binary>> = Bin, - case bin_search(Rest, Sep) of + Seps = search_compile(Seps0), + case bin_search(Rest, [], Seps) of {nomatch,_} -> {Bin, <<>>}; [SepStart] -> - case bin_search_inv(SepStart, [], Sep) of + case bin_search_inv(SepStart, [], GCs) of {nomatch,_} -> KeepSz = byte_size(Bin) - byte_size(SepStart), <<Before:KeepSz/binary, End/binary>> = Bin, {Before, End}; [NonSep] -> KeepSz = byte_size(Bin) - byte_size(NonSep), - take_t(Bin, KeepSz, Sep) + take_t(Bin, KeepSz, Seps) end end. -take_tc([Bin|Cont0], N, Sep) when is_binary(Bin) -> +take_tc([CP1|[CP2|_]=Cont], _, {GCs,_,_}=Seps) when ?ASCII_LIST(CP1,CP2) -> + case lists:member(CP1, GCs) of + false -> + {Head, Tail} = take_tc(Cont, 0, Seps), + case is_empty(Head) of + true -> {Head, append(CP1,Tail)}; + false -> {append(CP1,Head), Tail} + end; + true -> + {Head, Tail} = take_tc(Cont, 0, Seps), + {append(CP1,Head), Tail} + end; +take_tc([Bin|Cont0], N, {GCs,_,_}=Seps0) when is_binary(Bin) -> <<_:N/binary, Rest/binary>> = Bin, - case bin_search_inv(Rest, Cont0, Sep) of + case bin_search_inv(Rest, Cont0, GCs) of {nomatch,Cont} -> Used = cp_prefix(Cont0, Cont), - {Head, Tail} = take_tc(Cont, 0, Sep), + {Head, Tail} = take_tc(Cont, 0, Seps0), {stack(unicode:characters_to_binary([Bin|Used]), Head), Tail}; [SepStart|Cont1] -> - case bin_search(SepStart, Cont1, Sep) of + Seps = search_compile(Seps0), + case bin_search(SepStart, Cont1, Seps) of {nomatch, Cont} -> - {Head, Tail} = take_tc(Cont, 0, Sep), + {Head, Tail} = take_tc(Cont, 0, Seps), Used = cp_prefix(Cont0, Cont), - case equal(Tail, Cont) of + case is_empty(Head) of true -> KeepSz = byte_size(Bin) - byte_size(SepStart), <<Keep:KeepSz/binary, End/binary>> = Bin, - {stack(Keep,Head), stack(stack(End,Used),Tail)}; + {Keep, stack(stack(End,Used),Tail)}; false -> {stack(unicode:characters_to_binary([Bin|Used]),Head), Tail} end; [NonSep|Cont] when is_binary(NonSep) -> KeepSz = byte_size(Bin) - byte_size(NonSep), - take_tc([Bin|Cont], KeepSz, Sep) + take_tc([Bin|Cont], KeepSz, Seps) end end; -take_tc(Str, 0, {GCs,CPs,_}=Sep) when is_list(Str) -> - case unicode_util:cp(Str) of - [CP|Cs] -> - case lists:member(CP, CPs) of - true -> - [GC|Cs1] = unicode_util:gc(Str), - case lists:member(GC, GCs) of - false -> - {Head, Tail} = take_tc(Cs1, 0, Sep), - case equal(Tail, Cs1) of - true -> {Head, append(GC,Tail)}; - false -> {append(GC,Head), Tail} - end; - true -> - {Head, Tail} = take_tc(Cs1, 0, Sep), - {append(GC,Head), Tail} - end; +take_tc(Str, 0, {GCs,_,_}=Seps) when is_list(Str) -> + case unicode_util:gc(Str) of + [GC|Cs1] -> + case lists:member(GC, GCs) of false -> - {Head, Tail} = take_tc(Cs, 0, Sep), - case equal(Tail, Cs) of - true -> {Head, append(CP,Tail)}; - false -> {append(CP,Head), Tail} - end + {Head, Tail} = take_tc(Cs1, 0, Seps), + case is_empty(Head) of + true -> {Head, append(GC,Tail)}; + false -> {append(GC,Head), Tail} + end; + true -> + {Head, Tail} = take_tc(Cs1, 0, Seps), + {append(GC,Head), Tail} end; [] -> {[],[]} end; -take_tc(Bin, N, Sep) when is_binary(Bin) -> +take_tc(Bin, N, {GCs,_,_}=Seps0) when is_binary(Bin) -> <<_:N/binary, Rest/binary>> = Bin, - case bin_search_inv(Rest, [], Sep) of + case bin_search_inv(Rest, [], GCs) of {nomatch,_} -> {Bin, <<>>}; [SepStart] -> - case bin_search(SepStart, [], Sep) of + Seps = search_compile(Seps0), + case bin_search(SepStart, [], Seps) of {nomatch,_} -> KeepSz = byte_size(Bin) - byte_size(SepStart), <<Before:KeepSz/binary, End/binary>> = Bin, {Before, End}; [NonSep] -> KeepSz = byte_size(Bin) - byte_size(NonSep), - take_tc(Bin, KeepSz, Sep) + take_tc(Bin, KeepSz, Seps) end end. -prefix_1(Cs, []) -> Cs; -prefix_1(Cs, [_]=Pre) -> - prefix_2(unicode_util:gc(Cs), Pre); -prefix_1(Cs, Pre) -> - prefix_2(unicode_util:cp(Cs), Pre). - -prefix_2([C|Cs], [C|Pre]) -> - prefix_1(Cs, Pre); -prefix_2(_, _) -> - nomatch. +prefix_1(Cs0, [GC]) -> + case unicode_util:gc(Cs0) of + [GC|Cs] -> Cs; + _ -> nomatch + end; +prefix_1([CP|Cs], [Pre|PreR]) when is_integer(CP) -> + case CP =:= Pre of + true -> prefix_1(Cs,PreR); + false -> nomatch + end; +prefix_1(<<CP/utf8, Cs/binary>>, [Pre|PreR]) -> + case CP =:= Pre of + true -> prefix_1(Cs,PreR); + false -> nomatch + end; +prefix_1(Cs0, [Pre|PreR]) -> + case unicode_util:cp(Cs0) of + [Pre|Cs] -> prefix_1(Cs,PreR); + _ -> nomatch + end. +split_1([CP1|Cs]=Cs0, [C|_]=Needle, _, Where, Curr, Acc) when is_integer(CP1) -> + case CP1=:=C of + true -> + case prefix_1(Cs0, Needle) of + nomatch -> split_1(Cs, Needle, 0, Where, append(C,Curr), Acc); + Rest when Where =:= leading -> + [rev(Curr), Rest]; + Rest when Where =:= trailing -> + split_1(Cs, Needle, 0, Where, [C|Curr], [rev(Curr), Rest]); + Rest when Where =:= all -> + split_1(Rest, Needle, 0, Where, [], [rev(Curr)|Acc]) + end; + false -> + split_1(Cs, Needle, 0, Where, append(CP1,Curr), Acc) + end; split_1([Bin|Cont0], Needle, Start, Where, Curr0, Acc) when is_binary(Bin) -> case bin_search_str(Bin, Start, Cont0, Needle) of @@ -981,32 +1159,50 @@ split_1(Bin, [_C|_]=Needle, Start, Where, Curr0, Acc) -> end end. -lexemes_m([Bin|Cont0], Seps, Ts) when is_binary(Bin) -> - case bin_search_inv(Bin, Cont0, Seps) of +lexemes_m([CP|_]=Cs0, {GCs,CPs,_}=Seps, Ts) when is_integer(CP) -> + case lists:member(CP, CPs) of + true -> + [GC|Cs2] = unicode_util:gc(Cs0), + case lists:member(GC, GCs) of + true -> + lexemes_m(Cs2, Seps, Ts); + false -> + {Lexeme,Rest} = lexeme_pick(Cs0, Seps, []), + lexemes_m(Rest, Seps, [Lexeme|Ts]) + end; + false -> + {Lexeme,Rest} = lexeme_pick(Cs0, Seps, []), + lexemes_m(Rest, Seps, [Lexeme|Ts]) + end; +lexemes_m([Bin|Cont0], {GCs,_,_}=Seps0, Ts) when is_binary(Bin) -> + case bin_search_inv(Bin, Cont0, GCs) of {nomatch,Cont} -> - lexemes_m(Cont, Seps, Ts); + lexemes_m(Cont, Seps0, Ts); Cs -> + Seps = search_compile(Seps0), {Lexeme,Rest} = lexeme_pick(Cs, Seps, []), lexemes_m(Rest, Seps, [Lexeme|Ts]) end; -lexemes_m(Cs0, {GCs, _, _}=Seps, Ts) when is_list(Cs0) -> +lexemes_m(Cs0, {GCs, _, _}=Seps0, Ts) when is_list(Cs0) -> case unicode_util:gc(Cs0) of [C|Cs] -> case lists:member(C, GCs) of true -> - lexemes_m(Cs, Seps, Ts); + lexemes_m(Cs, Seps0, Ts); false -> + Seps = search_compile(Seps0), {Lexeme,Rest} = lexeme_pick(Cs0, Seps, []), lexemes_m(Rest, Seps, [Lexeme|Ts]) end; [] -> lists:reverse(Ts) end; -lexemes_m(Bin, Seps, Ts) when is_binary(Bin) -> - case bin_search_inv(Bin, [], Seps) of +lexemes_m(Bin, {GCs,_,_}=Seps0, Ts) when is_binary(Bin) -> + case bin_search_inv(Bin, [], GCs) of {nomatch,_} -> lists:reverse(Ts); [Cs] -> + Seps = search_compile(Seps0), {Lexeme,Rest} = lexeme_pick(Cs, Seps, []), lexemes_m(Rest, Seps, add_non_empty(Lexeme,Ts)) end. @@ -1037,7 +1233,7 @@ lexeme_pick(Cs0, {GCs, CPs, _} = Seps, Tkn) when is_list(Cs0) -> true -> [GC|Cs2] = unicode_util:gc(Cs0), case lists:member(GC, GCs) of - true -> {rev(Tkn), Cs0}; + true -> {rev(Tkn), Cs2}; false -> lexeme_pick(Cs2, Seps, append(rev(GC),Tkn)) end; false -> @@ -1047,7 +1243,7 @@ lexeme_pick(Cs0, {GCs, CPs, _} = Seps, Tkn) when is_list(Cs0) -> {rev(Tkn), []} end; lexeme_pick(Bin, Seps, Tkn) when is_binary(Bin) -> - case bin_search(Bin, Seps) of + case bin_search(Bin, [], Seps) of {nomatch,_} -> {btoken(Bin,Tkn), []}; [Left] -> @@ -1056,35 +1252,38 @@ lexeme_pick(Bin, Seps, Tkn) when is_binary(Bin) -> {btoken(Lexeme, Tkn), Left} end. -nth_lexeme_m([Bin|Cont0], Seps, N) when is_binary(Bin) -> - case bin_search_inv(Bin, Cont0, Seps) of +nth_lexeme_m([Bin|Cont0], {GCs,_,_}=Seps0, N) when is_binary(Bin) -> + case bin_search_inv(Bin, Cont0, GCs) of {nomatch,Cont} -> - nth_lexeme_m(Cont, Seps, N); + nth_lexeme_m(Cont, Seps0, N); Cs when N > 1 -> - Rest = lexeme_skip(Cs, Seps), - nth_lexeme_m(Rest, Seps, N-1); + Rest = lexeme_skip(Cs, Seps0), + nth_lexeme_m(Rest, Seps0, N-1); Cs -> + Seps = search_compile(Seps0), {Lexeme,_} = lexeme_pick(Cs, Seps, []), Lexeme end; -nth_lexeme_m(Cs0, {GCs, _, _}=Seps, N) when is_list(Cs0) -> +nth_lexeme_m(Cs0, {GCs, _, _}=Seps0, N) when is_list(Cs0) -> case unicode_util:gc(Cs0) of [C|Cs] -> case lists:member(C, GCs) of true -> - nth_lexeme_m(Cs, Seps, N); + nth_lexeme_m(Cs, Seps0, N); false when N > 1 -> - Cs1 = lexeme_skip(Cs, Seps), - nth_lexeme_m(Cs1, Seps, N-1); + Cs1 = lexeme_skip(Cs, Seps0), + nth_lexeme_m(Cs1, Seps0, N-1); false -> + Seps = search_compile(Seps0), {Lexeme,_} = lexeme_pick(Cs0, Seps, []), Lexeme end; [] -> [] end; -nth_lexeme_m(Bin, Seps, N) when is_binary(Bin) -> - case bin_search_inv(Bin, [], Seps) of +nth_lexeme_m(Bin, {GCs,_,_}=Seps0, N) when is_binary(Bin) -> + Seps = search_compile(Seps0), + case bin_search_inv(Bin, [], GCs) of [Cs] when N > 1 -> Cs1 = lexeme_skip(Cs, Seps), nth_lexeme_m(Cs1, Seps, N-1); @@ -1100,16 +1299,17 @@ lexeme_skip([CP|Cs1]=Cs0, {GCs,CPs,_}=Seps) when is_integer(CP) -> true -> [GC|Cs2] = unicode_util:gc(Cs0), case lists:member(GC, GCs) of - true -> Cs0; + true -> Cs2; false -> lexeme_skip(Cs2, Seps) end; false -> lexeme_skip(Cs1, Seps) end; -lexeme_skip([Bin|Cont0], Seps) when is_binary(Bin) -> +lexeme_skip([Bin|Cont0], Seps0) when is_binary(Bin) -> + Seps = search_compile(Seps0), case bin_search(Bin, Cont0, Seps) of {nomatch,_} -> lexeme_skip(Cont0, Seps); - Cs -> Cs + Cs -> tl(unicode_util:gc(Cs)) end; lexeme_skip(Cs0, {GCs, CPs, _} = Seps) when is_list(Cs0) -> case unicode_util:cp(Cs0) of @@ -1118,7 +1318,7 @@ lexeme_skip(Cs0, {GCs, CPs, _} = Seps) when is_list(Cs0) -> true -> [GC|Cs2] = unicode_util:gc(Cs0), case lists:member(GC, GCs) of - true -> Cs0; + true -> Cs2; false -> lexeme_skip(Cs2, Seps) end; false -> @@ -1127,12 +1327,23 @@ lexeme_skip(Cs0, {GCs, CPs, _} = Seps) when is_list(Cs0) -> [] -> [] end; -lexeme_skip(Bin, Seps) when is_binary(Bin) -> - case bin_search(Bin, Seps) of +lexeme_skip(Bin, Seps0) when is_binary(Bin) -> + Seps = search_compile(Seps0), + case bin_search(Bin, [], Seps) of {nomatch,_} -> <<>>; - [Left] -> Left + [Left] -> tl(unicode_util:gc(Left)) end. +find_l([C1|Cs]=Cs0, [C|_]=Needle) when is_integer(C1) -> + case C1 of + C -> + case prefix_1(Cs0, Needle) of + nomatch -> find_l(Cs, Needle); + _ -> Cs0 + end; + _ -> + find_l(Cs, Needle) + end; find_l([Bin|Cont0], Needle) when is_binary(Bin) -> case bin_search_str(Bin, 0, Cont0, Needle) of {nomatch, _, Cont} -> @@ -1157,6 +1368,16 @@ find_l(Bin, Needle) -> {_Before, [Cs], _After} -> Cs end. +find_r([Cp|Cs]=Cs0, [C|_]=Needle, Res) when is_integer(Cp) -> + case Cp of + C -> + case prefix_1(Cs0, Needle) of + nomatch -> find_r(Cs, Needle, Res); + _ -> find_r(Cs, Needle, Cs0) + end; + _ -> + find_r(Cs, Needle, Res) + end; find_r([Bin|Cont0], Needle, Res) when is_binary(Bin) -> case bin_search_str(Bin, 0, Cont0, Needle) of {nomatch,_,Cont} -> @@ -1227,11 +1448,6 @@ cp_prefix_1(Orig, Until, Cont) -> %% Binary special -bin_search(Bin, Seps) -> - bin_search(Bin, [], Seps). - -bin_search(_Bin, Cont, {[],_,_}) -> - {nomatch, Cont}; bin_search(Bin, Cont, {Seps,_,BP}) -> bin_search_loop(Bin, 0, BP, Cont, Seps). @@ -1239,10 +1455,14 @@ bin_search(Bin, Cont, {Seps,_,BP}) -> %% i.e. å in nfd form $a "COMBINING RING ABOVE" %% and PREPEND characters like "ARABIC NUMBER SIGN" 1536 <<216,128>> %% combined with other characters are currently ignored. +search_pattern({_,_,_}=P) -> P; search_pattern(Seps) -> CPs = search_cp(Seps), - Bin = bin_pattern(CPs), - {Seps, CPs, Bin}. + {Seps, CPs, undefined}. + +search_compile({Sep, CPs, undefined}) -> + {Sep, CPs, binary:compile_pattern(bin_pattern(CPs))}; +search_compile({_,_,_}=Compiled) -> Compiled. search_cp([CP|Seps]) when is_integer(CP) -> [CP|search_cp(Seps)]; @@ -1263,9 +1483,21 @@ bin_search_loop(Bin0, Start, BinSeps, Cont, Seps) -> case binary:match(Bin, BinSeps) of nomatch -> {nomatch,Cont}; + {Where, _CL} when Cont =:= [] -> + <<_:Where/binary, Cont1/binary>> = Bin, + [GC|Cont2] = unicode_util:gc(Cont1), + case lists:member(GC, Seps) of + false when Cont2 =:= [] -> + {nomatch, []}; + false -> + Next = byte_size(Bin0) - byte_size(Cont2), + bin_search_loop(Bin0, Next, BinSeps, Cont, Seps); + true -> + [Cont1] + end; {Where, _CL} -> <<_:Where/binary, Cont0/binary>> = Bin, - Cont1 = stack(Cont0, Cont), + Cont1 = [Cont0|Cont], [GC|Cont2] = unicode_util:gc(Cont1), case lists:member(GC, Seps) of false -> @@ -1273,55 +1505,108 @@ bin_search_loop(Bin0, Start, BinSeps, Cont, Seps) -> [BinR|Cont] when is_binary(BinR) -> Next = byte_size(Bin0) - byte_size(BinR), bin_search_loop(Bin0, Next, BinSeps, Cont, Seps); - BinR when is_binary(BinR), Cont =:= [] -> - Next = byte_size(Bin0) - byte_size(BinR), - bin_search_loop(Bin0, Next, BinSeps, Cont, Seps); _ -> {nomatch, Cont2} end; - true when is_list(Cont1) -> - Cont1; true -> - [Cont1] + Cont1 end end. -bin_search_inv(Bin, Cont, {[], _, _}) -> - [Bin|Cont]; -bin_search_inv(Bin, Cont, {[Sep], _, _}) -> - bin_search_inv_1([Bin|Cont], Sep); -bin_search_inv(Bin, Cont, {Seps, _, _}) -> - bin_search_inv_n([Bin|Cont], Seps). - -bin_search_inv_1([<<>>|CPs], _) -> - {nomatch, CPs}; -bin_search_inv_1(CPs = [Bin0|Cont], Sep) when is_binary(Bin0) -> - case unicode_util:gc(CPs) of - [Sep|Bin] when is_binary(Bin), Cont =:= [] -> - bin_search_inv_1([Bin], Sep); - [Sep|[Bin|Cont]=Cs] when is_binary(Bin) -> - bin_search_inv_1(Cs, Sep); - [Sep|Cs] -> - {nomatch, Cs}; - _ -> CPs - end. +bin_search_inv(<<>>, Cont, _) -> + {nomatch, Cont}; +bin_search_inv(Bin, Cont, [Sep]) -> + bin_search_inv_1(Bin, Cont, Sep); +bin_search_inv(Bin, Cont, Seps) -> + bin_search_inv_n(Bin, Cont, Seps). + +bin_search_inv_1(<<CP1/utf8, BinRest/binary>>=Bin0, Cont, Sep) -> + case BinRest of + <<CP2/utf8, _/binary>> when ?ASCII_LIST(CP1, CP2) -> + case CP1 of + Sep -> bin_search_inv_1(BinRest, Cont, Sep); + _ -> [Bin0|Cont] + end; + _ when Cont =:= [] -> + case unicode_util:gc(Bin0) of + [Sep|Bin] -> bin_search_inv_1(Bin, Cont, Sep); + _ -> [Bin0|Cont] + end; + _ -> + case unicode_util:gc([Bin0|Cont]) of + [Sep|[Bin|Cont]] when is_binary(Bin) -> + bin_search_inv_1(Bin, Cont, Sep); + [Sep|Cs] -> + {nomatch, Cs}; + _ -> [Bin0|Cont] + end + end; +bin_search_inv_1(<<>>, Cont, _Sep) -> + {nomatch, Cont}; +bin_search_inv_1([], Cont, _Sep) -> + {nomatch, Cont}. -bin_search_inv_n([<<>>|CPs], _) -> - {nomatch, CPs}; -bin_search_inv_n([Bin0|Cont]=CPs, Seps) when is_binary(Bin0) -> - [C|Cs0] = unicode_util:gc(CPs), - case {lists:member(C, Seps), Cs0} of - {true, Cs} when is_binary(Cs), Cont =:= [] -> - bin_search_inv_n([Cs], Seps); - {true, [Bin|Cont]=Cs} when is_binary(Bin) -> - bin_search_inv_n(Cs, Seps); - {true, Cs} -> {nomatch, Cs}; - {false, _} -> CPs - end. +bin_search_inv_n(<<CP1/utf8, BinRest/binary>>=Bin0, Cont, Seps) -> + case BinRest of + <<CP2/utf8, _/binary>> when ?ASCII_LIST(CP1, CP2) -> + case lists:member(CP1,Seps) of + true -> bin_search_inv_n(BinRest, Cont, Seps); + false -> [Bin0|Cont] + end; + _ when Cont =:= [] -> + [GC|Bin] = unicode_util:gc(Bin0), + case lists:member(GC, Seps) of + true -> bin_search_inv_n(Bin, Cont, Seps); + false -> [Bin0|Cont] + end; + _ -> + [GC|Cs0] = unicode_util:gc([Bin0|Cont]), + case lists:member(GC, Seps) of + false -> [Bin0|Cont]; + true -> + case Cs0 of + [Bin|Cont] when is_binary(Bin) -> + bin_search_inv_n(Bin, Cont, Seps); + _ -> + {nomatch, Cs0} + end + end + end; +bin_search_inv_n(<<>>, Cont, _Sep) -> + {nomatch, Cont}; +bin_search_inv_n([], Cont, _Sep) -> + {nomatch, Cont}. + +bin_search_str(Bin0, Start, [], SearchCPs) -> + Compiled = binary:compile_pattern(unicode:characters_to_binary(SearchCPs)), + bin_search_str_1(Bin0, Start, Compiled, SearchCPs); bin_search_str(Bin0, Start, Cont, [CP|_]=SearchCPs) -> + First = binary:compile_pattern(<<CP/utf8>>), + bin_search_str_2(Bin0, Start, Cont, First, SearchCPs). + +bin_search_str_1(Bin0, Start, First, SearchCPs) -> + <<_:Start/binary, Bin/binary>> = Bin0, + case binary:match(Bin, First) of + nomatch -> {nomatch, byte_size(Bin0), []}; + {Where0, _} -> + Where = Start+Where0, + <<Keep:Where/binary, Cs0/binary>> = Bin0, + case prefix_1(Cs0, SearchCPs) of + nomatch -> + <<_/utf8, Cs/binary>> = Cs0, + KeepSz = byte_size(Bin0) - byte_size(Cs), + bin_search_str_1(Bin0, KeepSz, First, SearchCPs); + [] -> + {Keep, [Cs0], <<>>}; + Rest -> + {Keep, [Cs0], Rest} + end + end. + +bin_search_str_2(Bin0, Start, Cont, First, SearchCPs) -> <<_:Start/binary, Bin/binary>> = Bin0, - case binary:match(Bin, <<CP/utf8>>) of + case binary:match(Bin, First) of nomatch -> {nomatch, byte_size(Bin0), Cont}; {Where0, _} -> Where = Start+Where0, @@ -1330,7 +1615,7 @@ bin_search_str(Bin0, Start, Cont, [CP|_]=SearchCPs) -> case prefix_1(stack(Cs0,Cont), SearchCPs) of nomatch when is_binary(Cs) -> KeepSz = byte_size(Bin0) - byte_size(Cs), - bin_search_str(Bin0, KeepSz, Cont, SearchCPs); + bin_search_str_2(Bin0, KeepSz, Cont, First, SearchCPs); nomatch -> {nomatch, Where, stack([GC|Cs],Cont)}; [] -> diff --git a/lib/stdlib/src/supervisor.erl b/lib/stdlib/src/supervisor.erl index 7920e55930..e56415650f 100644 --- a/lib/stdlib/src/supervisor.erl +++ b/lib/stdlib/src/supervisor.erl @@ -31,7 +31,6 @@ %% Internal exports -export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, code_change/3, format_status/2]). --export([try_again_restart/2]). %% For release_handler only -export([get_callback_module/1]). @@ -79,6 +78,7 @@ | {RestartStrategy :: strategy(), Intensity :: non_neg_integer(), Period :: pos_integer()}. +-type children() :: {Ids :: [child_id()], Db :: #{child_id() => child_rec()}}. %%-------------------------------------------------------------------------- %% Defaults @@ -96,7 +96,7 @@ pid = undefined :: child() | {restarting, pid() | undefined} | [pid()], - name :: child_id(), + id :: child_id(), mfargs :: mfargs(), restart_type :: restart(), shutdown :: shutdown(), @@ -104,16 +104,11 @@ modules = [] :: modules()}). -type child_rec() :: #child{}. --define(DICTS, dict). --define(DICT, dict:dict). --define(SETS, sets). --define(SET, sets:set). - -record(state, {name, strategy :: strategy() | 'undefined', - children = [] :: [child_rec()], - dynamics :: {'dict', ?DICT(pid(), list())} - | {'set', ?SET(pid())} + children = {[],#{}} :: children(), % Ids in start order + dynamics :: {'maps', #{pid() => list()}} + | {'sets', sets:set(pid())} | 'undefined', intensity :: non_neg_integer() | 'undefined', period :: pos_integer() | 'undefined', @@ -124,6 +119,9 @@ -type state() :: #state{}. -define(is_simple(State), State#state.strategy =:= simple_one_for_one). +-define(is_temporary(_Child_), _Child_#child.restart_type=:=temporary). +-define(is_transient(_Child_), _Child_#child.restart_type=:=transient). +-define(is_permanent(_Child_), _Child_#child.restart_type=:=permanent). -callback init(Args :: term()) -> {ok, {SupFlags :: sup_flags(), [ChildSpec :: child_spec()]}} @@ -179,16 +177,16 @@ start_child(Supervisor, ChildSpec) -> | {'error', Error}, Error :: 'running' | 'restarting' | 'not_found' | 'simple_one_for_one' | term(). -restart_child(Supervisor, Name) -> - call(Supervisor, {restart_child, Name}). +restart_child(Supervisor, Id) -> + call(Supervisor, {restart_child, Id}). -spec delete_child(SupRef, Id) -> Result when SupRef :: sup_ref(), Id :: child_id(), Result :: 'ok' | {'error', Error}, Error :: 'running' | 'restarting' | 'not_found' | 'simple_one_for_one'. -delete_child(Supervisor, Name) -> - call(Supervisor, {delete_child, Name}). +delete_child(Supervisor, Id) -> + call(Supervisor, {delete_child, Id}). %%----------------------------------------------------------------- %% Func: terminate_child/2 @@ -202,16 +200,16 @@ delete_child(Supervisor, Name) -> Id :: pid() | child_id(), Result :: 'ok' | {'error', Error}, Error :: 'not_found' | 'simple_one_for_one'. -terminate_child(Supervisor, Name) -> - call(Supervisor, {terminate_child, Name}). +terminate_child(Supervisor, Id) -> + call(Supervisor, {terminate_child, Id}). -spec get_childspec(SupRef, Id) -> Result when SupRef :: sup_ref(), Id :: pid() | child_id(), Result :: {'ok', child_spec()} | {'error', Error}, Error :: 'not_found'. -get_childspec(Supervisor, Name) -> - call(Supervisor, {get_childspec, Name}). +get_childspec(Supervisor, Id) -> + call(Supervisor, {get_childspec, Id}). -spec which_children(SupRef) -> [{Id,Child,Type,Modules}] when SupRef :: sup_ref(), @@ -246,17 +244,6 @@ check_childspecs(ChildSpecs) when is_list(ChildSpecs) -> check_childspecs(X) -> {error, {badarg, X}}. %%%----------------------------------------------------------------- -%%% Called by restart/2 --spec try_again_restart(SupRef, Child) -> ok when - SupRef :: sup_ref(), - Child :: child_id() | pid(). -try_again_restart(Supervisor, Child) -> - cast(Supervisor, {try_again_restart, Child}). - -cast(Supervisor, Req) -> - gen_server:cast(Supervisor, Req). - -%%%----------------------------------------------------------------- %%% Called by release_handler during upgrade -spec get_callback_module(Pid) -> Module when Pid :: pid(), @@ -325,7 +312,7 @@ init_children(State, StartSpec) -> init_dynamic(State, [StartSpec]) -> case check_startspec([StartSpec]) of {ok, Children} -> - {ok, State#state{children = Children}}; + {ok, dyn_init(State#state{children = Children})}; Error -> {stop, {start_spec, Error}} end; @@ -334,35 +321,34 @@ init_dynamic(_State, StartSpec) -> %%----------------------------------------------------------------- %% Func: start_children/2 -%% Args: Children = [child_rec()] in start order +%% Args: Children = children() % Ids in start order %% SupName = {local, atom()} | {global, atom()} | {pid(), Mod} -%% Purpose: Start all children. The new list contains #child's +%% Purpose: Start all children. The new map contains #child's %% with pids. %% Returns: {ok, NChildren} | {error, NChildren, Reason} -%% NChildren = [child_rec()] in termination order (reversed -%% start order) +%% NChildren = children() % Ids in termination order +%% (reversed start order) %%----------------------------------------------------------------- -start_children(Children, SupName) -> start_children(Children, [], SupName). - -start_children([Child|Chs], NChildren, SupName) -> - case do_start_child(SupName, Child) of - {ok, undefined} when Child#child.restart_type =:= temporary -> - start_children(Chs, NChildren, SupName); - {ok, Pid} -> - start_children(Chs, [Child#child{pid = Pid}|NChildren], SupName); - {ok, Pid, _Extra} -> - start_children(Chs, [Child#child{pid = Pid}|NChildren], SupName); - {error, Reason} -> - report_error(start_error, Reason, Child, SupName), - {error, lists:reverse(Chs) ++ [Child | NChildren], - {failed_to_start_child,Child#child.name,Reason}} - end; -start_children([], NChildren, _SupName) -> - {ok, NChildren}. +start_children(Children, SupName) -> + Start = + fun(Id,Child) -> + case do_start_child(SupName, Child) of + {ok, undefined} when ?is_temporary(Child) -> + remove; + {ok, Pid} -> + {update,Child#child{pid = Pid}}; + {ok, Pid, _Extra} -> + {update,Child#child{pid = Pid}}; + {error, Reason} -> + report_error(start_error, Reason, Child, SupName), + {abort,{failed_to_start_child,Id,Reason}} + end + end, + children_map(Start,Children). do_start_child(SupName, Child) -> #child{mfargs = {M, F, Args}} = Child, - case catch apply(M, F, Args) of + case do_start_child_i(M, F, Args) of {ok, Pid} when is_pid(Pid) -> NChild = Child#child{pid = Pid}, report_progress(NChild, SupName), @@ -371,10 +357,8 @@ do_start_child(SupName, Child) -> NChild = Child#child{pid = Pid}, report_progress(NChild, SupName), {ok, Pid, Extra}; - ignore -> - {ok, undefined}; - {error, What} -> {error, What}; - What -> {error, What} + Other -> + Other end. do_start_child_i(M, F, A) -> @@ -400,17 +384,17 @@ do_start_child_i(M, F, A) -> -spec handle_call(call(), term(), state()) -> {'reply', term(), state()}. handle_call({start_child, EArgs}, _From, State) when ?is_simple(State) -> - Child = hd(State#state.children), + Child = get_dynamic_child(State), #child{mfargs = {M, F, A}} = Child, Args = A ++ EArgs, case do_start_child_i(M, F, Args) of {ok, undefined} -> {reply, {ok, undefined}, State}; {ok, Pid} -> - NState = save_dynamic_child(Child#child.restart_type, Pid, Args, State), + NState = dyn_store(Pid, Args, State), {reply, {ok, Pid}, NState}; {ok, Pid, Extra} -> - NState = save_dynamic_child(Child#child.restart_type, Pid, Args, State), + NState = dyn_store(Pid, Args, State), {reply, {ok, Pid, Extra}, NState}; What -> {reply, What, State} @@ -426,121 +410,94 @@ handle_call({start_child, ChildSpec}, _From, State) -> end; %% terminate_child for simple_one_for_one can only be done with pid -handle_call({terminate_child, Name}, _From, State) when not is_pid(Name), - ?is_simple(State) -> +handle_call({terminate_child, Id}, _From, State) when not is_pid(Id), + ?is_simple(State) -> {reply, {error, simple_one_for_one}, State}; -handle_call({terminate_child, Name}, _From, State) -> - case get_child(Name, State, ?is_simple(State)) of - {value, Child} -> - case do_terminate(Child, State#state.name) of - #child{restart_type=RT} when RT=:=temporary; ?is_simple(State) -> - {reply, ok, state_del_child(Child, State)}; - NChild -> - {reply, ok, replace_child(NChild, State)} - end; - false -> +handle_call({terminate_child, Id}, _From, State) -> + case find_child(Id, State) of + {ok, Child} -> + do_terminate(Child, State#state.name), + {reply, ok, del_child(Child, State)}; + error -> {reply, {error, not_found}, State} end; %% restart_child request is invalid for simple_one_for_one supervisors -handle_call({restart_child, _Name}, _From, State) when ?is_simple(State) -> +handle_call({restart_child, _Id}, _From, State) when ?is_simple(State) -> {reply, {error, simple_one_for_one}, State}; -handle_call({restart_child, Name}, _From, State) -> - case get_child(Name, State) of - {value, Child} when Child#child.pid =:= undefined -> +handle_call({restart_child, Id}, _From, State) -> + case find_child(Id, State) of + {ok, Child} when Child#child.pid =:= undefined -> case do_start_child(State#state.name, Child) of {ok, Pid} -> - NState = replace_child(Child#child{pid = Pid}, State), + NState = set_pid(Pid, Id, State), {reply, {ok, Pid}, NState}; {ok, Pid, Extra} -> - NState = replace_child(Child#child{pid = Pid}, State), + NState = set_pid(Pid, Id, State), {reply, {ok, Pid, Extra}, NState}; Error -> {reply, Error, State} end; - {value, #child{pid=?restarting(_)}} -> + {ok, #child{pid=?restarting(_)}} -> {reply, {error, restarting}, State}; - {value, _} -> + {ok, _} -> {reply, {error, running}, State}; _ -> {reply, {error, not_found}, State} end; %% delete_child request is invalid for simple_one_for_one supervisors -handle_call({delete_child, _Name}, _From, State) when ?is_simple(State) -> +handle_call({delete_child, _Id}, _From, State) when ?is_simple(State) -> {reply, {error, simple_one_for_one}, State}; -handle_call({delete_child, Name}, _From, State) -> - case get_child(Name, State) of - {value, Child} when Child#child.pid =:= undefined -> - NState = remove_child(Child, State), +handle_call({delete_child, Id}, _From, State) -> + case find_child(Id, State) of + {ok, Child} when Child#child.pid =:= undefined -> + NState = remove_child(Id, State), {reply, ok, NState}; - {value, #child{pid=?restarting(_)}} -> + {ok, #child{pid=?restarting(_)}} -> {reply, {error, restarting}, State}; - {value, _} -> + {ok, _} -> {reply, {error, running}, State}; _ -> {reply, {error, not_found}, State} end; -handle_call({get_childspec, Name}, _From, State) -> - case get_child(Name, State, ?is_simple(State)) of - {value, Child} -> +handle_call({get_childspec, Id}, _From, State) -> + case find_child(Id, State) of + {ok, Child} -> {reply, {ok, child_to_spec(Child)}, State}; - false -> + error -> {reply, {error, not_found}, State} end; -handle_call(which_children, _From, #state{children = [#child{restart_type = temporary, - child_type = CT, - modules = Mods}]} = - State) when ?is_simple(State) -> - Reply = lists:map(fun(Pid) -> {undefined, Pid, CT, Mods} end, - ?SETS:to_list(dynamics_db(temporary, State#state.dynamics))), - {reply, Reply, State}; - -handle_call(which_children, _From, #state{children = [#child{restart_type = RType, - child_type = CT, - modules = Mods}]} = - State) when ?is_simple(State) -> - Reply = lists:map(fun({?restarting(_),_}) -> {undefined,restarting,CT,Mods}; - ({Pid, _}) -> {undefined, Pid, CT, Mods} end, - ?DICTS:to_list(dynamics_db(RType, State#state.dynamics))), +handle_call(which_children, _From, State) when ?is_simple(State) -> + #child{child_type = CT,modules = Mods} = get_dynamic_child(State), + Reply = dyn_map(fun(?restarting(_)) -> {undefined, restarting, CT, Mods}; + (Pid) -> {undefined, Pid, CT, Mods} + end, State), {reply, Reply, State}; handle_call(which_children, _From, State) -> Resp = - lists:map(fun(#child{pid = ?restarting(_), name = Name, - child_type = ChildType, modules = Mods}) -> - {Name, restarting, ChildType, Mods}; - (#child{pid = Pid, name = Name, - child_type = ChildType, modules = Mods}) -> - {Name, Pid, ChildType, Mods} - end, - State#state.children), + children_to_list( + fun(Id,#child{pid = ?restarting(_), + child_type = ChildType, modules = Mods}) -> + {Id, restarting, ChildType, Mods}; + (Id,#child{pid = Pid, + child_type = ChildType, modules = Mods}) -> + {Id, Pid, ChildType, Mods} + end, + State#state.children), {reply, Resp, State}; - -handle_call(count_children, _From, #state{children = [#child{restart_type = temporary, - child_type = CT}]} = State) - when ?is_simple(State) -> - Sz = ?SETS:size(dynamics_db(temporary, State#state.dynamics)), - Reply = case CT of - supervisor -> [{specs, 1}, {active, Sz}, - {supervisors, Sz}, {workers, 0}]; - worker -> [{specs, 1}, {active, Sz}, - {supervisors, 0}, {workers, Sz}] - end, - {reply, Reply, State}; - -handle_call(count_children, _From, #state{dynamic_restarts = Restarts, - children = [#child{restart_type = RType, - child_type = CT}]} = State) +handle_call(count_children, _From, #state{dynamic_restarts = Restarts} = State) when ?is_simple(State) -> - Sz = ?DICTS:size(dynamics_db(RType, State#state.dynamics)), - Active = Sz - Restarts, + #child{child_type = CT} = get_dynamic_child(State), + Sz = dyn_size(State), + Active = Sz - Restarts, % Restarts is always 0 for temporary children Reply = case CT of supervisor -> [{specs, 1}, {active, Active}, {supervisors, Sz}, {workers, 0}]; @@ -552,16 +509,15 @@ handle_call(count_children, _From, #state{dynamic_restarts = Restarts, handle_call(count_children, _From, State) -> %% Specs and children are together on the children list... {Specs, Active, Supers, Workers} = - lists:foldl(fun(Child, Counts) -> - count_child(Child, Counts) - end, {0,0,0,0}, State#state.children), + children_fold(fun(_Id, Child, Counts) -> + count_child(Child, Counts) + end, {0,0,0,0}, State#state.children), %% Reformat counts to a property list. Reply = [{specs, Specs}, {active, Active}, {supervisors, Supers}, {workers, Workers}], {reply, Reply, State}. - count_child(#child{pid = Pid, child_type = worker}, {Specs, Active, Supers, Workers}) -> case is_pid(Pid) andalso is_process_alive(Pid) of @@ -575,34 +531,15 @@ count_child(#child{pid = Pid, child_type = supervisor}, false -> {Specs+1, Active, Supers+1, Workers} end. - %%% If a restart attempt failed, this message is cast %%% from restart/2 in order to give gen_server the chance to %%% check it's inbox before trying again. --spec handle_cast({try_again_restart, child_id() | pid()}, state()) -> +-spec handle_cast({try_again_restart, child_id() | {'restarting',pid()}}, state()) -> {'noreply', state()} | {stop, shutdown, state()}. -handle_cast({try_again_restart,Pid}, #state{children=[Child]}=State) - when ?is_simple(State) -> - RT = Child#child.restart_type, - RPid = restarting(Pid), - case dynamic_child_args(RPid, RT, State#state.dynamics) of - {ok, Args} -> - {M, F, _} = Child#child.mfargs, - NChild = Child#child{pid = RPid, mfargs = {M, F, Args}}, - case restart(NChild,State) of - {ok, State1} -> - {noreply, State1}; - {shutdown, State1} -> - {stop, shutdown, State1} - end; - error -> - {noreply, State} - end; - -handle_cast({try_again_restart,Name}, State) -> - case lists:keyfind(Name,#child.name,State#state.children) of - Child = #child{pid=?restarting(_)} -> +handle_cast({try_again_restart,TryAgainId}, State) -> + case find_child_and_args(TryAgainId, State) of + {ok, Child = #child{pid=?restarting(_)}} -> case restart(Child,State) of {ok, State1} -> {noreply, State1}; @@ -637,10 +574,8 @@ handle_info(Msg, State) -> %% -spec terminate(term(), state()) -> 'ok'. -terminate(_Reason, #state{children=[Child]} = State) when ?is_simple(State) -> - terminate_dynamic_children(Child, dynamics_db(Child#child.restart_type, - State#state.dynamics), - State#state.name); +terminate(_Reason, State) when ?is_simple(State) -> + terminate_dynamic_children(State); terminate(_Reason, State) -> terminate_children(State#state.children, State#state.name). @@ -675,8 +610,8 @@ code_change(_, State, _) -> update_childspec(State, StartSpec) when ?is_simple(State) -> case check_startspec(StartSpec) of - {ok, [Child]} -> - {ok, State#state{children = [Child]}}; + {ok, {[_],_}=Children} -> + {ok, State#state{children = Children}}; Error -> {error, Error} end; @@ -690,39 +625,36 @@ update_childspec(State, StartSpec) -> {error, Error} end. -update_childspec1([Child|OldC], Children, KeepOld) -> - case update_chsp(Child, Children) of - {ok,NewChildren} -> - update_childspec1(OldC, NewChildren, KeepOld); +update_childspec1({[Id|OldIds], OldDb}, {Ids,Db}, KeepOld) -> + case update_chsp(maps:get(Id,OldDb), Db) of + {ok,NewDb} -> + update_childspec1({OldIds,OldDb}, {Ids,NewDb}, KeepOld); false -> - update_childspec1(OldC, Children, [Child|KeepOld]) + update_childspec1({OldIds,OldDb}, {Ids,Db}, [Id|KeepOld]) end; -update_childspec1([], Children, KeepOld) -> +update_childspec1({[],OldDb}, {Ids,Db}, KeepOld) -> + KeepOldDb = maps:with(KeepOld,OldDb), %% Return them in (kept) reverse start order. - lists:reverse(Children ++ KeepOld). - -update_chsp(OldCh, Children) -> - case lists:map(fun(Ch) when OldCh#child.name =:= Ch#child.name -> - Ch#child{pid = OldCh#child.pid}; - (Ch) -> - Ch - end, - Children) of - Children -> - false; % OldCh not found in new spec. - NewC -> - {ok, NewC} + {lists:reverse(Ids ++ KeepOld),maps:merge(KeepOldDb,Db)}. + +update_chsp(#child{id=Id}=OldChild, NewDb) -> + case maps:find(Id, NewDb) of + {ok,Child} -> + {ok,NewDb#{Id => Child#child{pid = OldChild#child.pid}}}; + error -> % Id not found in new spec. + false end. + %%% --------------------------------------------------- %%% Start a new child. %%% --------------------------------------------------- handle_start_child(Child, State) -> - case get_child(Child#child.name, State) of - false -> + case find_child(Child#child.id, State) of + error -> case do_start_child(State#state.name, Child) of - {ok, undefined} when Child#child.restart_type =:= temporary -> + {ok, undefined} when ?is_temporary(Child) -> {{ok, undefined}, State}; {ok, Pid} -> {{ok, Pid}, save_child(Child#child{pid = Pid}, State)}; @@ -731,9 +663,9 @@ handle_start_child(Child, State) -> {error, What} -> {{error, {What, Child}}, State} end; - {value, OldChild} when is_pid(OldChild#child.pid) -> + {ok, OldChild} when is_pid(OldChild#child.pid) -> {{error, {already_started, OldChild#child.pid}}, State}; - {value, _OldChild} -> + {ok, _OldChild} -> {{error, already_present}, State} end. @@ -742,63 +674,45 @@ handle_start_child(Child, State) -> %%% Returns: {ok, state()} | {shutdown, state()} %%% --------------------------------------------------- -restart_child(Pid, Reason, #state{children = [Child]} = State) when ?is_simple(State) -> - RestartType = Child#child.restart_type, - case dynamic_child_args(Pid, RestartType, State#state.dynamics) of - {ok, Args} -> - {M, F, _} = Child#child.mfargs, - NChild = Child#child{pid = Pid, mfargs = {M, F, Args}}, - do_restart(RestartType, Reason, NChild, State); - error -> - {ok, State} - end; - restart_child(Pid, Reason, State) -> - Children = State#state.children, - case lists:keyfind(Pid, #child.pid, Children) of - #child{restart_type = RestartType} = Child -> - do_restart(RestartType, Reason, Child, State); - false -> + case find_child_and_args(Pid, State) of + {ok, Child} -> + do_restart(Reason, Child, State); + error -> {ok, State} end. -do_restart(permanent, Reason, Child, State) -> +do_restart(Reason, Child, State) when ?is_permanent(Child) -> report_error(child_terminated, Reason, Child, State#state.name), restart(Child, State); -do_restart(_, normal, Child, State) -> - NState = state_del_child(Child, State), +do_restart(normal, Child, State) -> + NState = del_child(Child, State), {ok, NState}; -do_restart(_, shutdown, Child, State) -> - NState = state_del_child(Child, State), +do_restart(shutdown, Child, State) -> + NState = del_child(Child, State), {ok, NState}; -do_restart(_, {shutdown, _Term}, Child, State) -> - NState = state_del_child(Child, State), +do_restart({shutdown, _Term}, Child, State) -> + NState = del_child(Child, State), {ok, NState}; -do_restart(transient, Reason, Child, State) -> +do_restart(Reason, Child, State) when ?is_transient(Child) -> report_error(child_terminated, Reason, Child, State#state.name), restart(Child, State); -do_restart(temporary, Reason, Child, State) -> +do_restart(Reason, Child, State) when ?is_temporary(Child) -> report_error(child_terminated, Reason, Child, State#state.name), - NState = state_del_child(Child, State), + NState = del_child(Child, State), {ok, NState}. restart(Child, State) -> case add_restart(State) of {ok, NState} -> case restart(NState#state.strategy, Child, NState) of - {try_again,NState2} -> + {{try_again, TryAgainId}, NState2} -> %% Leaving control back to gen_server before %% trying again. This way other incoming requsts %% for the supervisor can be handled - e.g. a %% shutdown request for the supervisor or the %% child. - Id = if ?is_simple(State) -> Child#child.pid; - true -> Child#child.name - end, - ok = try_again_restart(self(), Id), - {ok,NState2}; - {try_again, NState2, #child{name=ChName}} -> - ok = try_again_restart(self(), ChName), + try_again_restart(TryAgainId), {ok,NState2}; Other -> Other @@ -806,124 +720,111 @@ restart(Child, State) -> {terminate, NState} -> report_error(shutdown, reached_max_restart_intensity, Child, State#state.name), - {shutdown, remove_child(Child, NState)} + {shutdown, del_child(Child, NState)} end. restart(simple_one_for_one, Child, State0) -> #child{pid = OldPid, mfargs = {M, F, A}} = Child, - State = case OldPid of + State1 = case OldPid of ?restarting(_) -> NRes = State0#state.dynamic_restarts - 1, State0#state{dynamic_restarts = NRes}; _ -> State0 end, - Dynamics = ?DICTS:erase(OldPid, dynamics_db(Child#child.restart_type, - State#state.dynamics)), + State2 = dyn_erase(OldPid, State1), case do_start_child_i(M, F, A) of {ok, Pid} -> - DynamicsDb = {dict, ?DICTS:store(Pid, A, Dynamics)}, - NState = State#state{dynamics = DynamicsDb}, + NState = dyn_store(Pid, A, State2), {ok, NState}; {ok, Pid, _Extra} -> - DynamicsDb = {dict, ?DICTS:store(Pid, A, Dynamics)}, - NState = State#state{dynamics = DynamicsDb}, + NState = dyn_store(Pid, A, State2), {ok, NState}; {error, Error} -> - NRestarts = State#state.dynamic_restarts + 1, - DynamicsDb = {dict, ?DICTS:store(restarting(OldPid), A, Dynamics)}, - NState = State#state{dynamic_restarts = NRestarts, - dynamics = DynamicsDb}, - report_error(start_error, Error, Child, State#state.name), - {try_again, NState} + ROldPid = restarting(OldPid), + NRestarts = State2#state.dynamic_restarts + 1, + State3 = State2#state{dynamic_restarts = NRestarts}, + NState = dyn_store(ROldPid, A, State3), + report_error(start_error, Error, Child, NState#state.name), + {{try_again, ROldPid}, NState} end; -restart(one_for_one, Child, State) -> +restart(one_for_one, #child{id=Id} = Child, State) -> OldPid = Child#child.pid, case do_start_child(State#state.name, Child) of {ok, Pid} -> - NState = replace_child(Child#child{pid = Pid}, State), + NState = set_pid(Pid, Id, State), {ok, NState}; {ok, Pid, _Extra} -> - NState = replace_child(Child#child{pid = Pid}, State), + NState = set_pid(Pid, Id, State), {ok, NState}; {error, Reason} -> - NState = replace_child(Child#child{pid = restarting(OldPid)}, State), + NState = set_pid(restarting(OldPid), Id, State), report_error(start_error, Reason, Child, State#state.name), - {try_again, NState} - end; -restart(rest_for_one, Child, State) -> - {ChAfter, ChBefore} = split_child(Child#child.pid, State#state.children), - ChAfter2 = terminate_children(ChAfter, State#state.name), - case start_children(ChAfter2, State#state.name) of - {ok, ChAfter3} -> - {ok, State#state{children = ChAfter3 ++ ChBefore}}; - {error, ChAfter3, {failed_to_start_child, ChName, _Reason}} - when ChName =:= Child#child.name -> - NChild = Child#child{pid=restarting(Child#child.pid)}, - NState = State#state{children = ChAfter3 ++ ChBefore}, - {try_again, replace_child(NChild,NState)}; - {error, ChAfter3, {failed_to_start_child, ChName, _Reason}} -> - NChild = lists:keyfind(ChName, #child.name, ChAfter3), - NChild2 = NChild#child{pid=?restarting(undefined)}, - NState = State#state{children = ChAfter3 ++ ChBefore}, - {try_again, replace_child(NChild2,NState), NChild2} + {{try_again,Id}, NState} end; -restart(one_for_all, Child, State) -> - Children1 = del_child(Child#child.pid, State#state.children), - Children2 = terminate_children(Children1, State#state.name), - case start_children(Children2, State#state.name) of - {ok, NChs} -> - {ok, State#state{children = NChs}}; - {error, NChs, {failed_to_start_child, ChName, _Reason}} - when ChName =:= Child#child.name -> - NChild = Child#child{pid=restarting(Child#child.pid)}, - NState = State#state{children = NChs}, - {try_again, replace_child(NChild,NState)}; - {error, NChs, {failed_to_start_child, ChName, _Reason}} -> - NChild = lists:keyfind(ChName, #child.name, NChs), - NChild2 = NChild#child{pid=?restarting(undefined)}, - NState = State#state{children = NChs}, - {try_again, replace_child(NChild2,NState), NChild2} +restart(rest_for_one, #child{id=Id} = Child, #state{name=SupName} = State) -> + {ChAfter, ChBefore} = split_child(Id, State#state.children), + {Return, ChAfter2} = restart_multiple_children(Child, ChAfter, SupName), + {Return, State#state{children = append(ChAfter2,ChBefore)}}; +restart(one_for_all, Child, #state{name=SupName} = State) -> + Children1 = del_child(Child#child.id, State#state.children), + {Return, NChildren} = restart_multiple_children(Child, Children1, SupName), + {Return, State#state{children = NChildren}}. + +restart_multiple_children(Child, Children, SupName) -> + Children1 = terminate_children(Children, SupName), + case start_children(Children1, SupName) of + {ok, NChildren} -> + {ok, NChildren}; + {error, NChildren, {failed_to_start_child, FailedId, _Reason}} -> + NewPid = if FailedId =:= Child#child.id -> + restarting(Child#child.pid); + true -> + ?restarting(undefined) + end, + {{try_again, FailedId}, set_pid(NewPid,FailedId,NChildren)} end. restarting(Pid) when is_pid(Pid) -> ?restarting(Pid); restarting(RPid) -> RPid. +-spec try_again_restart(child_id() | {'restarting',pid()}) -> 'ok'. +try_again_restart(TryAgainId) -> + gen_server:cast(self(), {try_again_restart, TryAgainId}). + %%----------------------------------------------------------------- %% Func: terminate_children/2 -%% Args: Children = [child_rec()] in termination order +%% Args: Children = children() % Ids in termination order %% SupName = {local, atom()} | {global, atom()} | {pid(),Mod} -%% Returns: NChildren = [child_rec()] in -%% startup order (reversed termination order) +%% Returns: NChildren = children() % Ids in startup order +%% % (reversed termination order) %%----------------------------------------------------------------- terminate_children(Children, SupName) -> - terminate_children(Children, SupName, []). - -%% Temporary children should not be restarted and thus should -%% be skipped when building the list of terminated children, although -%% we do want them to be shut down as many functions from this module -%% use this function to just clear everything. -terminate_children([Child = #child{restart_type=temporary} | Children], SupName, Res) -> - _ = do_terminate(Child, SupName), - terminate_children(Children, SupName, Res); -terminate_children([Child | Children], SupName, Res) -> - NChild = do_terminate(Child, SupName), - terminate_children(Children, SupName, [NChild | Res]); -terminate_children([], _SupName, Res) -> - Res. + Terminate = + fun(_Id,Child) when ?is_temporary(Child) -> + %% Temporary children should not be restarted and thus should + %% be skipped when building the list of terminated children. + do_terminate(Child, SupName), + remove; + (_Id,Child) -> + do_terminate(Child, SupName), + {update,Child#child{pid=undefined}} + end, + {ok,NChildren} = children_map(Terminate, Children), + NChildren. do_terminate(Child, SupName) when is_pid(Child#child.pid) -> case shutdown(Child#child.pid, Child#child.shutdown) of ok -> ok; - {error, normal} when Child#child.restart_type =/= permanent -> + {error, normal} when not (?is_permanent(Child)) -> ok; {error, OtherReason} -> report_error(shutdown_error, OtherReason, Child, SupName) end, - Child#child{pid = undefined}; -do_terminate(Child, _SupName) -> - Child#child{pid = undefined}. + ok; +do_terminate(_Child, _SupName) -> + ok. %%----------------------------------------------------------------- %% Shutdowns a child. We must check the EXIT value @@ -996,66 +897,50 @@ monitor_child(Pid) -> ok end. - %%----------------------------------------------------------------- -%% Func: terminate_dynamic_children/3 -%% Args: Child = child_rec() -%% Dynamics = ?DICT() | ?SET() -%% SupName = {local, atom()} | {global, atom()} | {pid(),Mod} +%% Func: terminate_dynamic_children/1 +%% Args: State %% Returns: ok %% -%% %% Shutdown all dynamic children. This happens when the supervisor is %% stopped. Because the supervisor can have millions of dynamic children, we -%% can have an significative overhead here. +%% can have a significative overhead here. %%----------------------------------------------------------------- -terminate_dynamic_children(Child, Dynamics, SupName) -> - {Pids, EStack0} = monitor_dynamic_children(Child, Dynamics), - Sz = ?SETS:size(Pids), +terminate_dynamic_children(State) -> + Child = get_dynamic_child(State), + {Pids, EStack0} = monitor_dynamic_children(Child,State), + Sz = sets:size(Pids), EStack = case Child#child.shutdown of brutal_kill -> - ?SETS:fold(fun(P, _) -> exit(P, kill) end, ok, Pids), + sets:fold(fun(P, _) -> exit(P, kill) end, ok, Pids), wait_dynamic_children(Child, Pids, Sz, undefined, EStack0); infinity -> - ?SETS:fold(fun(P, _) -> exit(P, shutdown) end, ok, Pids), + sets:fold(fun(P, _) -> exit(P, shutdown) end, ok, Pids), wait_dynamic_children(Child, Pids, Sz, undefined, EStack0); Time -> - ?SETS:fold(fun(P, _) -> exit(P, shutdown) end, ok, Pids), + sets:fold(fun(P, _) -> exit(P, shutdown) end, ok, Pids), TRef = erlang:start_timer(Time, self(), kill), wait_dynamic_children(Child, Pids, Sz, TRef, EStack0) end, %% Unroll stacked errors and report them - ?DICTS:fold(fun(Reason, Ls, _) -> - report_error(shutdown_error, Reason, - Child#child{pid=Ls}, SupName) - end, ok, EStack). - - -monitor_dynamic_children(#child{restart_type=temporary}, Dynamics) -> - ?SETS:fold(fun(P, {Pids, EStack}) -> - case monitor_child(P) of - ok -> - {?SETS:add_element(P, Pids), EStack}; - {error, normal} -> - {Pids, EStack}; - {error, Reason} -> - {Pids, ?DICTS:append(Reason, P, EStack)} - end - end, {?SETS:new(), ?DICTS:new()}, Dynamics); -monitor_dynamic_children(#child{restart_type=RType}, Dynamics) -> - ?DICTS:fold(fun(P, _, {Pids, EStack}) when is_pid(P) -> - case monitor_child(P) of - ok -> - {?SETS:add_element(P, Pids), EStack}; - {error, normal} when RType =/= permanent -> - {Pids, EStack}; - {error, Reason} -> - {Pids, ?DICTS:append(Reason, P, EStack)} - end; - (?restarting(_), _, {Pids, EStack}) -> - {Pids, EStack} - end, {?SETS:new(), ?DICTS:new()}, Dynamics). - + dict:fold(fun(Reason, Ls, _) -> + report_error(shutdown_error, Reason, + Child#child{pid=Ls}, State#state.name) + end, ok, EStack). + +monitor_dynamic_children(Child,State) -> + dyn_fold(fun(P,{Pids, EStack}) when is_pid(P) -> + case monitor_child(P) of + ok -> + {sets:add_element(P, Pids), EStack}; + {error, normal} when not (?is_permanent(Child)) -> + {Pids, EStack}; + {error, Reason} -> + {Pids, dict:append(Reason, P, EStack)} + end; + (?restarting(_), {Pids, EStack}) -> + {Pids, EStack} + end, {sets:new(), dict:new()}, State). wait_dynamic_children(_Child, _Pids, 0, undefined, EStack) -> EStack; @@ -1073,39 +958,38 @@ wait_dynamic_children(#child{shutdown=brutal_kill} = Child, Pids, Sz, TRef, EStack) -> receive {'DOWN', _MRef, process, Pid, killed} -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, TRef, EStack); {'DOWN', _MRef, process, Pid, Reason} -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, - TRef, ?DICTS:append(Reason, Pid, EStack)) + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, + TRef, dict:append(Reason, Pid, EStack)) end; -wait_dynamic_children(#child{restart_type=RType} = Child, Pids, Sz, - TRef, EStack) -> +wait_dynamic_children(Child, Pids, Sz, TRef, EStack) -> receive {'DOWN', _MRef, process, Pid, shutdown} -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, TRef, EStack); {'DOWN', _MRef, process, Pid, {shutdown, _}} -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, TRef, EStack); - {'DOWN', _MRef, process, Pid, normal} when RType =/= permanent -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, + {'DOWN', _MRef, process, Pid, normal} when not (?is_permanent(Child)) -> + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, TRef, EStack); {'DOWN', _MRef, process, Pid, Reason} -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, - TRef, ?DICTS:append(Reason, Pid, EStack)); + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, + TRef, dict:append(Reason, Pid, EStack)); {timeout, TRef, kill} -> - ?SETS:fold(fun(P, _) -> exit(P, kill) end, ok, Pids), + sets:fold(fun(P, _) -> exit(P, kill) end, ok, Pids), wait_dynamic_children(Child, Pids, Sz, undefined, EStack) end. %%----------------------------------------------------------------- -%% Child/State manipulating functions. +%% Access #state.children %%----------------------------------------------------------------- %% Note we do not want to save the parameter list for temporary processes as @@ -1113,114 +997,184 @@ wait_dynamic_children(#child{restart_type=RType} = Child, Pids, Sz, %% Especially for dynamic children to simple_one_for_one supervisors %% it could become very costly as it is not uncommon to spawn %% very many such processes. -save_child(#child{restart_type = temporary, - mfargs = {M, F, _}} = Child, #state{children = Children} = State) -> - State#state{children = [Child#child{mfargs = {M, F, undefined}} |Children]}; -save_child(Child, #state{children = Children} = State) -> - State#state{children = [Child |Children]}. - -save_dynamic_child(temporary, Pid, _, #state{dynamics = Dynamics} = State) -> - DynamicsDb = dynamics_db(temporary, Dynamics), - State#state{dynamics = {set, ?SETS:add_element(Pid, DynamicsDb)}}; -save_dynamic_child(RestartType, Pid, Args, #state{dynamics = Dynamics} = State) -> - DynamicsDb = dynamics_db(RestartType, Dynamics), - State#state{dynamics = {dict, ?DICTS:store(Pid, Args, DynamicsDb)}}. - -dynamics_db(temporary, undefined) -> - ?SETS:new(); -dynamics_db(_, undefined) -> - ?DICTS:new(); -dynamics_db(_, {_Tag, DynamicsDb}) -> - DynamicsDb. - -dynamic_child_args(_Pid, temporary, _DynamicsDb) -> - {ok, undefined}; -dynamic_child_args(Pid, _RT, {dict, DynamicsDb}) -> - ?DICTS:find(Pid, DynamicsDb); -dynamic_child_args(_Pid, _RT, undefined) -> - error. - -state_del_child(#child{pid = Pid, restart_type = temporary}, State) when ?is_simple(State) -> - NDynamics = ?SETS:del_element(Pid, dynamics_db(temporary, State#state.dynamics)), - State#state{dynamics = {set, NDynamics}}; -state_del_child(#child{pid = Pid, restart_type = RType}, State) when ?is_simple(State) -> - NDynamics = ?DICTS:erase(Pid, dynamics_db(RType, State#state.dynamics)), - State#state{dynamics = {dict, NDynamics}}; -state_del_child(Child, State) -> - NChildren = del_child(Child#child.name, State#state.children), - State#state{children = NChildren}. - -del_child(Name, [Ch|Chs]) when Ch#child.name =:= Name, Ch#child.restart_type =:= temporary -> - Chs; -del_child(Name, [Ch|Chs]) when Ch#child.name =:= Name -> - [Ch#child{pid = undefined} | Chs]; -del_child(Pid, [Ch|Chs]) when Ch#child.pid =:= Pid, Ch#child.restart_type =:= temporary -> - Chs; -del_child(Pid, [Ch|Chs]) when Ch#child.pid =:= Pid -> - [Ch#child{pid = undefined} | Chs]; -del_child(Name, [Ch|Chs]) -> - [Ch|del_child(Name, Chs)]; -del_child(_, []) -> - []. +-spec save_child(child_rec(), state()) -> state(). +save_child(#child{mfargs = {M, F, _}} = Child, State) when ?is_temporary(Child) -> + do_save_child(Child#child{mfargs = {M, F, undefined}}, State); +save_child(Child, State) -> + do_save_child(Child, State). + +-spec do_save_child(child_rec(), state()) -> state(). +do_save_child(#child{id = Id} = Child, #state{children = {Ids,Db}} = State) -> + State#state{children = {[Id|Ids],Db#{Id => Child}}}. + +-spec del_child(child_rec(), state()) -> state(); + (child_id(), children()) -> children(). +del_child(#child{pid = Pid}, State) when ?is_simple(State) -> + dyn_erase(Pid,State); +del_child(Child, State) when is_record(Child,child), is_record(State,state) -> + NChildren = del_child(Child#child.id, State#state.children), + State#state{children = NChildren}; +del_child(Id, {Ids,Db}) -> + case maps:get(Id, Db) of + Child when Child#child.restart_type =:= temporary -> + {lists:delete(Id, Ids), maps:remove(Id, Db)}; + Child -> + {Ids, Db#{Id=>Child#child{pid=undefined}}} + end. -%% Chs = [S4, S3, Ch, S1, S0] -%% Ret: {[S4, S3, Ch], [S1, S0]} -split_child(Name, Chs) -> - split_child(Name, Chs, []). - -split_child(Name, [Ch|Chs], After) when Ch#child.name =:= Name -> - {lists:reverse([Ch#child{pid = undefined} | After]), Chs}; -split_child(Pid, [Ch|Chs], After) when Ch#child.pid =:= Pid -> - {lists:reverse([Ch#child{pid = undefined} | After]), Chs}; -split_child(Name, [Ch|Chs], After) -> - split_child(Name, Chs, [Ch | After]); -split_child(_, [], After) -> - {lists:reverse(After), []}. - -get_child(Name, State) -> - get_child(Name, State, false). - -get_child(Pid, State, AllowPid) when AllowPid, is_pid(Pid) -> - get_dynamic_child(Pid, State); -get_child(Name, State, _) -> - lists:keysearch(Name, #child.name, State#state.children). - -get_dynamic_child(Pid, #state{children=[Child], dynamics=Dynamics}) -> - case is_dynamic_pid(Pid, Dynamics) of - true -> - {value, Child#child{pid=Pid}}; - false -> - RPid = restarting(Pid), - case is_dynamic_pid(RPid, Dynamics) of - true -> - {value, Child#child{pid=RPid}}; - false -> +%% In: {[S4, S3, Ch, S1, S0],Db} +%% Ret: {{[S4, S3, Ch],Db1}, {[S1, S0],Db2}} +%% Db1 and Db2 contain the keys in the lists they are associated with. +-spec split_child(child_id(), children()) -> {children(), children()}. +split_child(Id, {Ids,Db}) -> + {IdsAfter,IdsBefore} = split_ids(Id, Ids, []), + DbBefore = maps:with(IdsBefore,Db), + #{Id:=Ch} = DbAfter = maps:with(IdsAfter,Db), + {{IdsAfter,DbAfter#{Id=>Ch#child{pid=undefined}}},{IdsBefore,DbBefore}}. + +split_ids(Id, [Id|Ids], After) -> + {lists:reverse([Id|After]), Ids}; +split_ids(Id, [Other|Ids], After) -> + split_ids(Id, Ids, [Other | After]). + +%% Find the child record for a given Pid (dynamic child) or Id +%% (non-dynamic child). This is called from the API functions. +-spec find_child(pid() | child_id(), state()) -> {ok,child_rec()} | error. +find_child(Pid, State) when is_pid(Pid), ?is_simple(State) -> + case find_dynamic_child(Pid, State) of + error -> + case find_dynamic_child(restarting(Pid), State) of + error -> case erlang:is_process_alive(Pid) of - true -> false; - false -> {value, Child} - end - end + true -> error; + false -> {ok, get_dynamic_child(State)} + end; + Other -> + Other + end; + Other -> + Other + end; +find_child(Id, #state{children = {_Ids,Db}}) -> + maps:find(Id, Db). + +%% Get the child record - either by child id or by pid. If +%% simple_one_for_one, then insert the pid and args into the returned +%% child record. This is called when trying to restart the child. +-spec find_child_and_args(IdOrPid, state()) -> {ok, child_rec()} | error when + IdOrPid :: pid() | {restarting,pid()} | child_id(). +find_child_and_args(Pid, State) when ?is_simple(State) -> + case find_dynamic_child(Pid, State) of + {ok,#child{mfargs={M,F,_}} = Child} -> + {ok, Args} = dyn_args(Pid, State), + {ok, Child#child{mfargs = {M, F, Args}}}; + error -> + error + end; +find_child_and_args(Pid, State) when is_pid(Pid) -> + find_child_by_pid(Pid, State); +find_child_and_args(Id, #state{children={_Ids,Db}}) -> + maps:find(Id, Db). + +%% Given the pid, find the child record for a dynamic child, and +%% include the pid in the returned record. +-spec find_dynamic_child(IdOrPid, state()) -> {ok, child_rec()} | error when + IdOrPid :: pid() | {restarting,pid()} | child_id(). +find_dynamic_child(Pid, State) -> + case dyn_exists(Pid, State) of + true -> + Child = get_dynamic_child(State), + {ok, Child#child{pid=Pid}}; + false -> + error end. -is_dynamic_pid(Pid, {dict, Dynamics}) -> - ?DICTS:is_key(Pid, Dynamics); -is_dynamic_pid(Pid, {set, Dynamics}) -> - ?SETS:is_element(Pid, Dynamics); -is_dynamic_pid(_Pid, undefined) -> - false. - -replace_child(Child, State) -> - Chs = do_replace_child(Child, State#state.children), - State#state{children = Chs}. - -do_replace_child(Child, [Ch|Chs]) when Ch#child.name =:= Child#child.name -> - [Child | Chs]; -do_replace_child(Child, [Ch|Chs]) -> - [Ch|do_replace_child(Child, Chs)]. +%% Given the pid, find the child record for a non-dyanamic child. +-spec find_child_by_pid(IdOrPid, state()) -> {ok,child_rec()} | error when + IdOrPid :: pid() | {restarting,pid()}. +find_child_by_pid(Pid,#state{children={_Ids,Db}}) -> + Fun = fun(_Id,#child{pid=P}=Ch,_) when P =:= Pid -> + throw(Ch); + (_,_,error) -> + error + end, + try maps:fold(Fun,error,Db) + catch throw:Child -> {ok,Child} + end. -remove_child(Child, State) -> - Chs = lists:keydelete(Child#child.name, #child.name, State#state.children), - State#state{children = Chs}. +%% Get the child record from a simple_one_for_one supervisor - no pid +%% It is assumed that the child can always be found +-spec get_dynamic_child(state()) -> child_rec(). +get_dynamic_child(#state{children={[Id],Db}}) -> + #{Id := Child} = Db, + Child. + +%% Update pid in the given child record and store it in the process state +-spec set_pid(term(), child_id(), state()) -> state(); + (term(), child_id(), children()) -> children(). +set_pid(Pid, Id, #state{children=Children} = State) -> + State#state{children = set_pid(Pid, Id, Children)}; +set_pid(Pid, Id, {Ids, Db}) -> + NewDb = maps:update_with(Id, fun(Child) -> Child#child{pid=Pid} end, Db), + {Ids,NewDb}. + +%% Remove the Id and the child record from the process state +-spec remove_child(child_id(), state()) -> state(). +remove_child(Id, #state{children={Ids,Db}} = State) -> + NewIds = lists:delete(Id,Ids), + NewDb = maps:remove(Id,Db), + State#state{children = {NewIds,NewDb}}. + +%% In the order of Ids, traverse the children and update each child +%% according to the return value of the Fun. +%% On error, abort and return the merge of the old and the updated map. +%% NOTE: The returned list of Ids is reverted compared to the input. +-spec children_map(Fun, children()) -> {ok, children()} | + {error,children(),Reason} when + Fun :: fun((child_id(),child_rec()) -> {update,child_rec()} | + remove | + {abort, Reason}), + Reason :: term(). +children_map(Fun,{Ids,Db}) -> + children_map(Fun, Ids, Db, []). + +children_map(Fun,[Id|Ids],Db,Acc) -> + case Fun(Id,maps:get(Id,Db)) of + {update,Child} -> + children_map(Fun,Ids,Db#{Id => Child},[Id|Acc]); + remove -> + children_map(Fun,Ids,maps:remove(Id,Db),Acc); + {abort,Reason} -> + {error,{lists:reverse(Ids)++[Id|Acc],Db},Reason} + end; +children_map(_Fun,[],Db,Acc) -> + {ok,{Acc,Db}}. + +%% In the order of Ids, map over all children and return the list +-spec children_to_list(Fun, children()) -> List when + Fun :: fun((child_id(), child_rec()) -> Elem), + List :: list(Elem), + Elem :: term(). +children_to_list(Fun,{Ids,Db}) -> + children_to_list(Fun, Ids, Db, []). +children_to_list(Fun,[Id|Ids],Db,Acc) -> + children_to_list(Fun,Ids,Db,[Fun(Id,maps:get(Id,Db))|Acc]); +children_to_list(_Fun,[],_Db,Acc) -> + lists:reverse(Acc). + +%% The order is not important - so ignore Ids +-spec children_fold(Fun, Acc0, children()) -> Acc1 when + Fun :: fun((child_id(), child_rec(), AccIn) -> AccOut), + Acc0 :: term(), + Acc1 :: term(), + AccIn :: term(), + AccOut :: term(). +children_fold(Fun,Init,{_Ids,Db}) -> + maps:fold(Fun, Init, Db). + +-spec append(children(), children()) -> children(). +append({Ids1,Db1},{Ids2,Db2}) -> + {Ids1++Ids2,maps:merge(Db1,Db2)}. %%----------------------------------------------------------------- %% Func: init_state/4 @@ -1290,27 +1244,27 @@ supname(N, _) -> N. %%% Returns: {ok, [child_rec()]} | Error %%% ------------------------------------------------------ -check_startspec(Children) -> check_startspec(Children, []). +check_startspec(Children) -> check_startspec(Children, [], #{}). -check_startspec([ChildSpec|T], Res) -> +check_startspec([ChildSpec|T], Ids, Db) -> case check_childspec(ChildSpec) of - {ok, Child} -> - case lists:keymember(Child#child.name, #child.name, Res) of + {ok, #child{id=Id}=Child} -> + case maps:is_key(Id, Db) of %% The error message duplicate_child_name is kept for %% backwards compatibility, although %% duplicate_child_id would be more correct. - true -> {duplicate_child_name, Child#child.name}; - false -> check_startspec(T, [Child | Res]) + true -> {duplicate_child_name, Id}; + false -> check_startspec(T, [Id | Ids], Db#{Id=>Child}) end; Error -> Error end; -check_startspec([], Res) -> - {ok, lists:reverse(Res)}. +check_startspec([], Ids, Db) -> + {ok, {lists:reverse(Ids),Db}}. check_childspec(ChildSpec) when is_map(ChildSpec) -> catch do_check_childspec(maps:merge(?default_child_spec,ChildSpec)); -check_childspec({Name, Func, RestartType, Shutdown, ChildType, Mods}) -> - check_childspec(#{id => Name, +check_childspec({Id, Func, RestartType, Shutdown, ChildType, Mods}) -> + check_childspec(#{id => Id, start => Func, restart => RestartType, shutdown => Shutdown, @@ -1320,15 +1274,15 @@ check_childspec(X) -> {invalid_child_spec, X}. do_check_childspec(#{restart := RestartType, type := ChildType} = ChildSpec)-> - Name = case ChildSpec of - #{id := N} -> N; + Id = case ChildSpec of + #{id := I} -> I; _ -> throw(missing_id) end, Func = case ChildSpec of #{start := F} -> F; _ -> throw(missing_start) end, - validName(Name), + validId(Id), validFunc(Func), validRestartType(RestartType), validChildType(ChildType), @@ -1343,14 +1297,14 @@ do_check_childspec(#{restart := RestartType, _ -> {M,_,_} = Func, [M] end, validMods(Mods), - {ok, #child{name = Name, mfargs = Func, restart_type = RestartType, + {ok, #child{id = Id, mfargs = Func, restart_type = RestartType, shutdown = Shutdown, child_type = ChildType, modules = Mods}}. validChildType(supervisor) -> true; validChildType(worker) -> true; validChildType(What) -> throw({invalid_child_type, What}). -validName(_Name) -> true. +validId(_Id) -> true. validFunc({M, F, A}) when is_atom(M), is_atom(F), @@ -1379,13 +1333,13 @@ validMods(Mods) when is_list(Mods) -> Mods); validMods(Mods) -> throw({invalid_modules, Mods}). -child_to_spec(#child{name = Name, +child_to_spec(#child{id = Id, mfargs = Func, restart_type = RestartType, shutdown = Shutdown, child_type = ChildType, modules = Mods}) -> - #{id => Name, + #{id => Id, start => Func, restart => RestartType, shutdown => Shutdown, @@ -1439,17 +1393,16 @@ report_error(Error, Reason, Child, SupName) -> {offender, extract_child(Child)}], error_logger:error_report(supervisor_report, ErrorMsg). - extract_child(Child) when is_list(Child#child.pid) -> [{nb_children, length(Child#child.pid)}, - {id, Child#child.name}, + {id, Child#child.id}, {mfargs, Child#child.mfargs}, {restart_type, Child#child.restart_type}, {shutdown, Child#child.shutdown}, {child_type, Child#child.child_type}]; extract_child(Child) -> [{pid, Child#child.pid}, - {id, Child#child.name}, + {id, Child#child.id}, {mfargs, Child#child.mfargs}, {restart_type, Child#child.restart_type}, {shutdown, Child#child.shutdown}, @@ -1465,3 +1418,46 @@ format_status(terminate, [_PDict, State]) -> format_status(_, [_PDict, State]) -> [{data, [{"State", State}]}, {supervisor, [{"Callback", State#state.module}]}]. + +%%%----------------------------------------------------------------- +%%% Dynamics database access +dyn_size(#state{dynamics = {Mod,Db}}) -> + Mod:size(Db). + +dyn_erase(Pid,#state{dynamics={sets,Db}}=State) -> + State#state{dynamics={sets,sets:del_element(Pid,Db)}}; +dyn_erase(Pid,#state{dynamics={maps,Db}}=State) -> + State#state{dynamics={maps,maps:remove(Pid,Db)}}. + +dyn_store(Pid,_,#state{dynamics={sets,Db}}=State) -> + State#state{dynamics={sets,sets:add_element(Pid,Db)}}; +dyn_store(Pid,Args,#state{dynamics={maps,Db}}=State) -> + State#state{dynamics={maps,Db#{Pid => Args}}}. + +dyn_fold(Fun,Init,#state{dynamics={sets,Db}}) -> + sets:fold(Fun,Init,Db); +dyn_fold(Fun,Init,#state{dynamics={maps,Db}}) -> + maps:fold(fun(Pid,_,Acc) -> Fun(Pid,Acc) end, Init, Db). + +dyn_map(Fun, #state{dynamics={sets,Db}}) -> + lists:map(Fun, sets:to_list(Db)); +dyn_map(Fun, #state{dynamics={maps,Db}}) -> + lists:map(Fun, maps:keys(Db)). + +dyn_exists(Pid, #state{dynamics={sets, Db}}) -> + sets:is_element(Pid, Db); +dyn_exists(Pid, #state{dynamics={maps, Db}}) -> + maps:is_key(Pid, Db). + +dyn_args(_Pid, #state{dynamics={sets, _Db}}) -> + {ok,undefined}; +dyn_args(Pid, #state{dynamics={maps, Db}}) -> + maps:find(Pid, Db). + +dyn_init(State) -> + dyn_init(get_dynamic_child(State),State). + +dyn_init(Child,State) when ?is_temporary(Child) -> + State#state{dynamics={sets,sets:new()}}; +dyn_init(_Child,State) -> + State#state{dynamics={maps,maps:new()}}. diff --git a/lib/stdlib/src/sys.erl b/lib/stdlib/src/sys.erl index 1f966411c5..0c578acf21 100644 --- a/lib/stdlib/src/sys.erl +++ b/lib/stdlib/src/sys.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -38,7 +38,9 @@ -export_type([dbg_opt/0]). --type name() :: pid() | atom() | {'global', atom()}. +-type name() :: pid() | atom() + | {'global', term()} + | {'via', module(), term()}. -type system_event() :: {'in', Msg :: _} | {'in', Msg :: _, From :: _} | {'out', Msg :: _, To :: _} diff --git a/lib/stdlib/src/uri_string.erl b/lib/stdlib/src/uri_string.erl new file mode 100644 index 0000000000..a84679c595 --- /dev/null +++ b/lib/stdlib/src/uri_string.erl @@ -0,0 +1,2069 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. 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% +%% +%% +%% [RFC 3986, Chapter 2.2. Reserved Characters] +%% +%% reserved = gen-delims / sub-delims +%% +%% gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@" +%% +%% sub-delims = "!" / "$" / "&" / "'" / "(" / ")" +%% / "*" / "+" / "," / ";" / "=" +%% +%% +%% [RFC 3986, Chapter 2.3. Unreserved Characters] +%% +%% unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" +%% +%% +%% [RFC 3986, Chapter 3. Syntax Components] +%% +%% The generic URI syntax consists of a hierarchical sequence of +%% components referred to as the scheme, authority, path, query, and +%% fragment. +%% +%% URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ] +%% +%% hier-part = "//" authority path-abempty +%% / path-absolute +%% / path-rootless +%% / path-empty +%% +%% The scheme and path components are required, though the path may be +%% empty (no characters). When authority is present, the path must +%% either be empty or begin with a slash ("/") character. When +%% authority is not present, the path cannot begin with two slash +%% characters ("//"). These restrictions result in five different ABNF +%% rules for a path (Section 3.3), only one of which will match any +%% given URI reference. +%% +%% The following are two example URIs and their component parts: +%% +%% foo://example.com:8042/over/there?name=ferret#nose +%% \_/ \______________/\_________/ \_________/ \__/ +%% | | | | | +%% scheme authority path query fragment +%% | _____________________|__ +%% / \ / \ +%% urn:example:animal:ferret:nose +%% +%% +%% [RFC 3986, Chapter 3.1. Scheme] +%% +%% Each URI begins with a scheme name that refers to a specification for +%% assigning identifiers within that scheme. +%% +%% scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." ) +%% +%% +%% [RFC 3986, Chapter 3.2. Authority] +%% +%% Many URI schemes include a hierarchical element for a naming +%% authority so that governance of the name space defined by the +%% remainder of the URI is delegated to that authority (which may, in +%% turn, delegate it further). +%% +%% authority = [ userinfo "@" ] host [ ":" port ] +%% +%% +%% [RFC 3986, Chapter 3.2.1. User Information] +%% +%% The userinfo subcomponent may consist of a user name and, optionally, +%% scheme-specific information about how to gain authorization to access +%% the resource. The user information, if present, is followed by a +%% commercial at-sign ("@") that delimits it from the host. +%% +%% userinfo = *( unreserved / pct-encoded / sub-delims / ":" ) +%% +%% +%% [RFC 3986, Chapter 3.2.2. Host] +%% +%% The host subcomponent of authority is identified by an IP literal +%% encapsulated within square brackets, an IPv4 address in dotted- +%% decimal form, or a registered name. +%% +%% host = IP-literal / IPv4address / reg-name +%% +%% IP-literal = "[" ( IPv6address / IPvFuture ) "]" +%% +%% IPvFuture = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" ) +%% +%% IPv6address = 6( h16 ":" ) ls32 +%% / "::" 5( h16 ":" ) ls32 +%% / [ h16 ] "::" 4( h16 ":" ) ls32 +%% / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32 +%% / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32 +%% / [ *3( h16 ":" ) h16 ] "::" h16 ":" ls32 +%% / [ *4( h16 ":" ) h16 ] "::" ls32 +%% / [ *5( h16 ":" ) h16 ] "::" h16 +%% / [ *6( h16 ":" ) h16 ] "::" +%% +%% ls32 = ( h16 ":" h16 ) / IPv4address +%% ; least-significant 32 bits of address +%% +%% h16 = 1*4HEXDIG +%% ; 16 bits of address represented in hexadecimal +%% +%% IPv4address = dec-octet "." dec-octet "." dec-octet "." dec-octet +%% +%% dec-octet = DIGIT ; 0-9 +%% / %x31-39 DIGIT ; 10-99 +%% / "1" 2DIGIT ; 100-199 +%% / "2" %x30-34 DIGIT ; 200-249 +%% / "25" %x30-35 ; 250-255 +%% +%% reg-name = *( unreserved / pct-encoded / sub-delims ) +%% +%% +%% [RFC 3986, Chapter 3.2.2. Port] +%% +%% The port subcomponent of authority is designated by an optional port +%% number in decimal following the host and delimited from it by a +%% single colon (":") character. +%% +%% port = *DIGIT +%% +%% +%% [RFC 3986, Chapter 3.3. Path] +%% +%% The path component contains data, usually organized in hierarchical +%% form, that, along with data in the non-hierarchical query component +%% (Section 3.4), serves to identify a resource within the scope of the +%% URI's scheme and naming authority (if any). The path is terminated +%% by the first question mark ("?") or number sign ("#") character, or +%% by the end of the URI. +%% +%% path = path-abempty ; begins with "/" or is empty +%% / path-absolute ; begins with "/" but not "//" +%% / path-noscheme ; begins with a non-colon segment +%% / path-rootless ; begins with a segment +%% / path-empty ; zero characters +%% +%% path-abempty = *( "/" segment ) +%% path-absolute = "/" [ segment-nz *( "/" segment ) ] +%% path-noscheme = segment-nz-nc *( "/" segment ) +%% path-rootless = segment-nz *( "/" segment ) +%% path-empty = 0<pchar> +%% segment = *pchar +%% segment-nz = 1*pchar +%% segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" ) +%% ; non-zero-length segment without any colon ":" +%% +%% pchar = unreserved / pct-encoded / sub-delims / ":" / "@" +%% +%% +%% [RFC 3986, Chapter 3.4. Query] +%% +%% The query component contains non-hierarchical data that, along with +%% data in the path component (Section 3.3), serves to identify a +%% resource within the scope of the URI's scheme and naming authority +%% (if any). The query component is indicated by the first question +%% mark ("?") character and terminated by a number sign ("#") character +%% or by the end of the URI. +%% +%% query = *( pchar / "/" / "?" ) +%% +%% +%% [RFC 3986, Chapter 3.5. Fragment] +%% +%% The fragment identifier component of a URI allows indirect +%% identification of a secondary resource by reference to a primary +%% resource and additional identifying information. +%% +%% fragment = *( pchar / "/" / "?" ) +%% +%% +%% [RFC 3986, Chapter 4.1. URI Reference] +%% +%% URI-reference is used to denote the most common usage of a resource +%% identifier. +%% +%% URI-reference = URI / relative-ref +%% +%% +%% [RFC 3986, Chapter 4.2. Relative Reference] +%% +%% A relative reference takes advantage of the hierarchical syntax +%% (Section 1.2.3) to express a URI reference relative to the name space +%% of another hierarchical URI. +%% +%% relative-ref = relative-part [ "?" query ] [ "#" fragment ] +%% +%% relative-part = "//" authority path-abempty +%% / path-absolute +%% / path-noscheme +%% / path-empty +%% +%% +%% [RFC 3986, Chapter 4.3. Absolute URI] +%% +%% Some protocol elements allow only the absolute form of a URI without +%% a fragment identifier. For example, defining a base URI for later +%% use by relative references calls for an absolute-URI syntax rule that +%% does not allow a fragment. +%% +%% absolute-URI = scheme ":" hier-part [ "?" query ] +%% +-module(uri_string). + +%%------------------------------------------------------------------------- +%% External API +%%------------------------------------------------------------------------- +-export([compose_query/1, compose_query/2, + dissect_query/1, normalize/1, parse/1, + recompose/1, transcode/2]). +-export_type([error/0, uri_map/0, uri_string/0]). + + +%%------------------------------------------------------------------------- +%% Internal API +%%------------------------------------------------------------------------- +-export([is_host/1, is_path/1]). % suppress warnings + + +%%------------------------------------------------------------------------- +%% Macros +%%------------------------------------------------------------------------- +-define(CHAR(Char), <<Char/utf8>>). +-define(STRING_EMPTY, <<>>). +-define(STRING(MatchStr), <<MatchStr/binary>>). +-define(STRING_REST(MatchStr, Rest), <<MatchStr/utf8, Rest/binary>>). + +-define(DEC2HEX(X), + if ((X) >= 0) andalso ((X) =< 9) -> (X) + $0; + ((X) >= 10) andalso ((X) =< 15) -> (X) + $A - 10 + end). + +-define(HEX2DEC(X), + if ((X) >= $0) andalso ((X) =< $9) -> (X) - $0; + ((X) >= $A) andalso ((X) =< $F) -> (X) - $A + 10; + ((X) >= $a) andalso ((X) =< $f) -> (X) - $a + 10 + end). + + +%%%========================================================================= +%%% API +%%%========================================================================= + +%%------------------------------------------------------------------------- +%% URI compliant with RFC 3986 +%% ASCII %x21 - %x7A ("!" - "z") except +%% %x34 " double quote +%% %x60 < less than +%% %x62 > greater than +%% %x92 \ backslash +%% %x94 ^ caret / circumflex +%% %x96 ` grave / accent +%%------------------------------------------------------------------------- +-type uri_string() :: iodata(). +-type error() :: {error, atom(), term()}. + + +%%------------------------------------------------------------------------- +%% RFC 3986, Chapter 3. Syntax Components +%%------------------------------------------------------------------------- +-type uri_map() :: + #{fragment => unicode:chardata(), + host => unicode:chardata(), + path => unicode:chardata(), + port => non_neg_integer() | undefined, + query => unicode:chardata(), + scheme => unicode:chardata(), + userinfo => unicode:chardata()} | #{}. + + +%%------------------------------------------------------------------------- +%% Normalize URIs +%%------------------------------------------------------------------------- +-spec normalize(URIString) -> NormalizedURI when + URIString :: uri_string(), + NormalizedURI :: uri_string(). +normalize(URIString) -> + %% Percent-encoding normalization and case normalization for + %% percent-encoded triplets are achieved by running parse and + %% recompose on the input URI string. + recompose( + normalize_path_segment( + normalize_scheme_based( + normalize_case( + parse(URIString))))). + + +%%------------------------------------------------------------------------- +%% Parse URIs +%%------------------------------------------------------------------------- +-spec parse(URIString) -> URIMap when + URIString :: uri_string(), + URIMap :: uri_map() + | error(). +parse(URIString) when is_binary(URIString) -> + try parse_uri_reference(URIString, #{}) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end; +parse(URIString) when is_list(URIString) -> + try + Binary = unicode:characters_to_binary(URIString), + Map = parse_uri_reference(Binary, #{}), + convert_mapfields_to_list(Map) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end. + + +%%------------------------------------------------------------------------- +%% Recompose URIs +%%------------------------------------------------------------------------- +-spec recompose(URIMap) -> URIString when + URIMap :: uri_map(), + URIString :: uri_string() + | error(). +recompose(Map) -> + case is_valid_map(Map) of + false -> + {error, invalid_map, Map}; + true -> + try + T0 = update_scheme(Map, empty), + T1 = update_userinfo(Map, T0), + T2 = update_host(Map, T1), + T3 = update_port(Map, T2), + T4 = update_path(Map, T3), + T5 = update_query(Map, T4), + update_fragment(Map, T5) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end + end. + + +%%------------------------------------------------------------------------- +%% Transcode URIs +%%------------------------------------------------------------------------- +-spec transcode(URIString, Options) -> Result when + URIString :: uri_string(), + Options :: [{in_encoding, unicode:encoding()}|{out_encoding, unicode:encoding()}], + Result :: uri_string() + | error(). +transcode(URIString, Options) when is_binary(URIString) -> + try + InEnc = proplists:get_value(in_encoding, Options, utf8), + OutEnc = proplists:get_value(out_encoding, Options, utf8), + List = convert_to_list(URIString, InEnc), + Output = transcode(List, [], InEnc, OutEnc), + convert_to_binary(Output, utf8, OutEnc) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end; +transcode(URIString, Options) when is_list(URIString) -> + InEnc = proplists:get_value(in_encoding, Options, utf8), + OutEnc = proplists:get_value(out_encoding, Options, utf8), + Flattened = flatten_list(URIString, InEnc), + try transcode(Flattened, [], InEnc, OutEnc) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end. + + +%%------------------------------------------------------------------------- +%% Functions for working with the query part of a URI as a list +%% of key/value pairs. +%% HTML5 - 4.10.22.6 URL-encoded form data +%%------------------------------------------------------------------------- + +%%------------------------------------------------------------------------- +%% Compose urlencoded query string from a list of unescaped key/value pairs. +%% (application/x-www-form-urlencoded encoding algorithm) +%%------------------------------------------------------------------------- +-spec compose_query(QueryList) -> QueryString when + QueryList :: [{uri_string(), uri_string()}], + QueryString :: uri_string() + | error(). +compose_query(List) -> + compose_query(List, [{encoding, utf8}]). + + +-spec compose_query(QueryList, Options) -> QueryString when + QueryList :: [{uri_string(), uri_string()}], + Options :: [{encoding, atom()}], + QueryString :: uri_string() + | error(). +compose_query([],_Options) -> + []; +compose_query(List, Options) -> + try compose_query(List, Options, false, <<>>) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end. +%% +compose_query([{Key,Value}|Rest], Options, IsList, Acc) -> + Separator = get_separator(Rest), + K = form_urlencode(Key, Options), + V = form_urlencode(Value, Options), + IsListNew = IsList orelse is_list(Key) orelse is_list(Value), + compose_query(Rest, Options, IsListNew, <<Acc/binary,K/binary,"=",V/binary,Separator/binary>>); +compose_query([], _Options, IsList, Acc) -> + case IsList of + true -> convert_to_list(Acc, utf8); + false -> Acc + end. + + +%%------------------------------------------------------------------------- +%% Dissect a query string into a list of unescaped key/value pairs. +%% (application/x-www-form-urlencoded decoding algorithm) +%%------------------------------------------------------------------------- +-spec dissect_query(QueryString) -> QueryList when + QueryString :: uri_string(), + QueryList :: [{uri_string(), uri_string()}] + | error(). +dissect_query(<<>>) -> + []; +dissect_query([]) -> + []; +dissect_query(QueryString) when is_list(QueryString) -> + try + B = convert_to_binary(QueryString, utf8, utf8), + dissect_query_key(B, true, [], <<>>, <<>>) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end; +dissect_query(QueryString) -> + try dissect_query_key(QueryString, false, [], <<>>, <<>>) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end. + + +%%%======================================================================== +%%% Internal functions +%%%======================================================================== + +%%------------------------------------------------------------------------- +%% Converts Map fields to lists +%%------------------------------------------------------------------------- +convert_mapfields_to_list(Map) -> + Fun = fun (_, V) when is_binary(V) -> unicode:characters_to_list(V); + (_, V) -> V end, + maps:map(Fun, Map). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 4.1. URI Reference] +%% +%% URI-reference is used to denote the most common usage of a resource +%% identifier. +%% +%% URI-reference = URI / relative-ref +%%------------------------------------------------------------------------- +-spec parse_uri_reference(binary(), uri_map()) -> uri_map(). +parse_uri_reference(<<>>, _) -> #{path => <<>>}; +parse_uri_reference(URIString, URI) -> + try parse_scheme_start(URIString, URI) + catch + throw:{_,_,_} -> + parse_relative_part(URIString, URI) + end. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 4.2. Relative Reference] +%% +%% A relative reference takes advantage of the hierarchical syntax +%% (Section 1.2.3) to express a URI reference relative to the name space +%% of another hierarchical URI. +%% +%% relative-ref = relative-part [ "?" query ] [ "#" fragment ] +%% +%% relative-part = "//" authority path-abempty +%% / path-absolute +%% / path-noscheme +%% / path-empty +%%------------------------------------------------------------------------- +-spec parse_relative_part(binary(), uri_map()) -> uri_map(). +parse_relative_part(?STRING_REST("//", Rest), URI) -> + %% Parse userinfo - "//" is NOT part of authority + try parse_userinfo(Rest, URI) of + {T, URI1} -> + Userinfo = calculate_parsed_userinfo(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{userinfo => decode_userinfo(Userinfo)} + catch + throw:{_,_,_} -> + {T, URI1} = parse_host(Rest, URI), + Host = calculate_parsed_host_port(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{host => decode_host(remove_brackets(Host))} + end; +parse_relative_part(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-absolute + Path = calculate_parsed_part(Rest, T), + URI1#{path => decode_path(?STRING_REST($/, Path))}; +parse_relative_part(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{query => decode_query(Query)}; +parse_relative_part(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{fragment => decode_fragment(Fragment)}; +parse_relative_part(?STRING_REST(Char, Rest), URI) -> + case is_segment_nz_nc(Char) of + true -> + {T, URI1} = parse_segment_nz_nc(Rest, URI), % path-noscheme + Path = calculate_parsed_part(Rest, T), + URI1#{path => decode_path(?STRING_REST(Char, Path))}; + false -> throw({error,invalid_uri,[Char]}) + end. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.3. Path] +%% +%% The path component contains data, usually organized in hierarchical +%% form, that, along with data in the non-hierarchical query component +%% (Section 3.4), serves to identify a resource within the scope of the +%% URI's scheme and naming authority (if any). The path is terminated +%% by the first question mark ("?") or number sign ("#") character, or +%% by the end of the URI. +%% +%% path = path-abempty ; begins with "/" or is empty +%% / path-absolute ; begins with "/" but not "//" +%% / path-noscheme ; begins with a non-colon segment +%% / path-rootless ; begins with a segment +%% / path-empty ; zero characters +%% +%% path-abempty = *( "/" segment ) +%% path-absolute = "/" [ segment-nz *( "/" segment ) ] +%% path-noscheme = segment-nz-nc *( "/" segment ) +%% path-rootless = segment-nz *( "/" segment ) +%% path-empty = 0<pchar> +%% segment = *pchar +%% segment-nz = 1*pchar +%% segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" ) +%% ; non-zero-length segment without any colon ":" +%% +%% pchar = unreserved / pct-encoded / sub-delims / ":" / "@" +%%------------------------------------------------------------------------- + +%%------------------------------------------------------------------------- +%% path-abempty +%%------------------------------------------------------------------------- +-spec parse_segment(binary(), uri_map()) -> {binary(), uri_map()}. +parse_segment(?STRING_REST($/, Rest), URI) -> + parse_segment(Rest, URI); % segment +parse_segment(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_segment(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_segment(?STRING_REST(Char, Rest), URI) -> + case is_pchar(Char) of + true -> parse_segment(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_segment(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%%------------------------------------------------------------------------- +%% path-noscheme +%%------------------------------------------------------------------------- +-spec parse_segment_nz_nc(binary(), uri_map()) -> {binary(), uri_map()}. +parse_segment_nz_nc(?STRING_REST($/, Rest), URI) -> + parse_segment(Rest, URI); % segment +parse_segment_nz_nc(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_segment_nz_nc(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_segment_nz_nc(?STRING_REST(Char, Rest), URI) -> + case is_segment_nz_nc(Char) of + true -> parse_segment_nz_nc(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_segment_nz_nc(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%% Check if char is pchar. +-spec is_pchar(char()) -> boolean(). +is_pchar($%) -> true; % pct-encoded +is_pchar($:) -> true; +is_pchar($@) -> true; +is_pchar(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + +%% Check if char is segment_nz_nc. +-spec is_segment_nz_nc(char()) -> boolean(). +is_segment_nz_nc($%) -> true; % pct-encoded +is_segment_nz_nc($@) -> true; +is_segment_nz_nc(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.1. Scheme] +%% +%% Each URI begins with a scheme name that refers to a specification for +%% assigning identifiers within that scheme. +%% +%% scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." ) +%%------------------------------------------------------------------------- +-spec parse_scheme_start(binary(), uri_map()) -> uri_map(). +parse_scheme_start(?STRING_REST(Char, Rest), URI) -> + case is_alpha(Char) of + true -> {T, URI1} = parse_scheme(Rest, URI), + Scheme = calculate_parsed_scheme(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{scheme => ?STRING_REST(Char, Scheme)}; + false -> throw({error,invalid_uri,[Char]}) + end. + +%% Add path component if it missing after parsing the URI. +%% According to the URI specification there is always a +%% path component in every URI-reference and it can be +%% empty. +maybe_add_path(Map) -> + case maps:is_key(path, Map) of + false -> + Map#{path => <<>>}; + _Else -> + Map + end. + + + +-spec parse_scheme(binary(), uri_map()) -> {binary(), uri_map()}. +parse_scheme(?STRING_REST($:, Rest), URI) -> + {_, URI1} = parse_hier(Rest, URI), + {Rest, URI1}; +parse_scheme(?STRING_REST(Char, Rest), URI) -> + case is_scheme(Char) of + true -> parse_scheme(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_scheme(?STRING_EMPTY, _URI) -> + throw({error,invalid_uri,<<>>}). + + +%% Check if char is allowed in scheme +-spec is_scheme(char()) -> boolean(). +is_scheme($+) -> true; +is_scheme($-) -> true; +is_scheme($.) -> true; +is_scheme(Char) -> is_alpha(Char) orelse is_digit(Char). + + +%%------------------------------------------------------------------------- +%% hier-part = "//" authority path-abempty +%% / path-absolute +%% / path-rootless +%% / path-empty +%%------------------------------------------------------------------------- +-spec parse_hier(binary(), uri_map()) -> {binary(), uri_map()}. +parse_hier(?STRING_REST("//", Rest), URI) -> + % Parse userinfo - "//" is NOT part of authority + try parse_userinfo(Rest, URI) of + {T, URI1} -> + Userinfo = calculate_parsed_userinfo(Rest, T), + {Rest, URI1#{userinfo => decode_userinfo(Userinfo)}} + catch + throw:{_,_,_} -> + {T, URI1} = parse_host(Rest, URI), + Host = calculate_parsed_host_port(Rest, T), + {Rest, URI1#{host => decode_host(remove_brackets(Host))}} + end; +parse_hier(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-absolute + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => decode_path(?STRING_REST($/, Path))}}; +parse_hier(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_hier(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_hier(?STRING_REST(Char, Rest), URI) -> % path-rootless + case is_pchar(Char) of + true -> % segment_nz + {T, URI1} = parse_segment(Rest, URI), + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => decode_path(?STRING_REST(Char, Path))}}; + false -> throw({error,invalid_uri,[Char]}) + end; +parse_hier(?STRING_EMPTY, URI) -> + {<<>>, URI}. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.2. Authority] +%% +%% Many URI schemes include a hierarchical element for a naming +%% authority so that governance of the name space defined by the +%% remainder of the URI is delegated to that authority (which may, in +%% turn, delegate it further). +%% +%% The authority component is preceded by a double slash ("//") and is +%% terminated by the next slash ("/"), question mark ("?"), or number +%% sign ("#") character, or by the end of the URI. +%% +%% authority = [ userinfo "@" ] host [ ":" port ] +%% +%% +%% [RFC 3986, Chapter 3.2.1. User Information] +%% +%% The userinfo subcomponent may consist of a user name and, optionally, +%% scheme-specific information about how to gain authorization to access +%% the resource. The user information, if present, is followed by a +%% commercial at-sign ("@") that delimits it from the host. +%% +%% userinfo = *( unreserved / pct-encoded / sub-delims / ":" ) +%%------------------------------------------------------------------------- +-spec parse_userinfo(binary(), uri_map()) -> {binary(), uri_map()}. +parse_userinfo(?CHAR($@), URI) -> + {?STRING_EMPTY, URI#{host => <<>>}}; +parse_userinfo(?STRING_REST($@, Rest), URI) -> + {T, URI1} = parse_host(Rest, URI), + Host = calculate_parsed_host_port(Rest, T), + {Rest, URI1#{host => decode_host(remove_brackets(Host))}}; +parse_userinfo(?STRING_REST(Char, Rest), URI) -> + case is_userinfo(Char) of + true -> parse_userinfo(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_userinfo(?STRING_EMPTY, _URI) -> + %% URI cannot end in userinfo state + throw({error,invalid_uri,<<>>}). + + +%% Check if char is allowed in userinfo +-spec is_userinfo(char()) -> boolean(). +is_userinfo($%) -> true; % pct-encoded +is_userinfo($:) -> true; +is_userinfo(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.2.2. Host] +%% +%% The host subcomponent of authority is identified by an IP literal +%% encapsulated within square brackets, an IPv4 address in dotted- +%% decimal form, or a registered name. +%% +%% host = IP-literal / IPv4address / reg-name +%% +%% IP-literal = "[" ( IPv6address / IPvFuture ) "]" +%% +%% IPvFuture = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" ) +%% +%% IPv6address = 6( h16 ":" ) ls32 +%% / "::" 5( h16 ":" ) ls32 +%% / [ h16 ] "::" 4( h16 ":" ) ls32 +%% / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32 +%% / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32 +%% / [ *3( h16 ":" ) h16 ] "::" h16 ":" ls32 +%% / [ *4( h16 ":" ) h16 ] "::" ls32 +%% / [ *5( h16 ":" ) h16 ] "::" h16 +%% / [ *6( h16 ":" ) h16 ] "::" +%% +%% ls32 = ( h16 ":" h16 ) / IPv4address +%% ; least-significant 32 bits of address +%% +%% h16 = 1*4HEXDIG +%% ; 16 bits of address represented in hexadecimal +%% +%% IPv4address = dec-octet "." dec-octet "." dec-octet "." dec-octet +%% +%% dec-octet = DIGIT ; 0-9 +%% / %x31-39 DIGIT ; 10-99 +%% / "1" 2DIGIT ; 100-199 +%% / "2" %x30-34 DIGIT ; 200-249 +%% / "25" %x30-35 ; 250-255 +%% +%% reg-name = *( unreserved / pct-encoded / sub-delims ) +%%------------------------------------------------------------------------- +-spec parse_host(binary(), uri_map()) -> {binary(), uri_map()}. +parse_host(?STRING_REST($:, Rest), URI) -> + {T, URI1} = parse_port(Rest, URI), + H = calculate_parsed_host_port(Rest, T), + Port = get_port(H), + {Rest, URI1#{port => Port}}; +parse_host(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => decode_path(?STRING_REST($/, Path))}}; +parse_host(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_host(?STRING_REST($[, Rest), URI) -> + parse_ipv6_bin(Rest, [], URI); +parse_host(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_host(?STRING_REST(Char, Rest), URI) -> + case is_digit(Char) of + true -> parse_ipv4_bin(Rest, [Char], URI); + false -> parse_reg_name(?STRING_REST(Char, Rest), URI) + end; +parse_host(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +-spec parse_reg_name(binary(), uri_map()) -> {binary(), uri_map()}. +parse_reg_name(?STRING_REST($:, Rest), URI) -> + {T, URI1} = parse_port(Rest, URI), + H = calculate_parsed_host_port(Rest, T), + Port = get_port(H), + {Rest, URI1#{port => Port}}; +parse_reg_name(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => decode_path(?STRING_REST($/, Path))}}; +parse_reg_name(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_reg_name(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_reg_name(?STRING_REST(Char, Rest), URI) -> + case is_reg_name(Char) of + true -> parse_reg_name(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_reg_name(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + +%% Check if char is allowed in reg-name +-spec is_reg_name(char()) -> boolean(). +is_reg_name($%) -> true; +is_reg_name(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + + +-spec parse_ipv4_bin(binary(), list(), uri_map()) -> {binary(), uri_map()}. +parse_ipv4_bin(?STRING_REST($:, Rest), Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {T, URI1} = parse_port(Rest, URI), + H = calculate_parsed_host_port(Rest, T), + Port = get_port(H), + {Rest, URI1#{port => Port}}; +parse_ipv4_bin(?STRING_REST($/, Rest), Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => decode_path(?STRING_REST($/, Path))}}; +parse_ipv4_bin(?STRING_REST($?, Rest), Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_ipv4_bin(?STRING_REST($#, Rest), Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_ipv4_bin(?STRING_REST(Char, Rest), Acc, URI) -> + case is_ipv4(Char) of + true -> parse_ipv4_bin(Rest, [Char|Acc], URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_ipv4_bin(?STRING_EMPTY, Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {?STRING_EMPTY, URI}. + + +%% Check if char is allowed in IPv4 addresses +-spec is_ipv4(char()) -> boolean(). +is_ipv4($.) -> true; +is_ipv4(Char) -> is_digit(Char). + +-spec validate_ipv4_address(list()) -> list(). +validate_ipv4_address(Addr) -> + case inet:parse_ipv4strict_address(Addr) of + {ok, _} -> Addr; + {error, _} -> throw({error,invalid_uri,Addr}) + end. + + +-spec parse_ipv6_bin(binary(), list(), uri_map()) -> {binary(), uri_map()}. +parse_ipv6_bin(?STRING_REST($], Rest), Acc, URI) -> + _ = validate_ipv6_address(lists:reverse(Acc)), + parse_ipv6_bin_end(Rest, URI); +parse_ipv6_bin(?STRING_REST(Char, Rest), Acc, URI) -> + case is_ipv6(Char) of + true -> parse_ipv6_bin(Rest, [Char|Acc], URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_ipv6_bin(?STRING_EMPTY, _Acc, _URI) -> + throw({error,invalid_uri,<<>>}). + +%% Check if char is allowed in IPv6 addresses +-spec is_ipv6(char()) -> boolean(). +is_ipv6($:) -> true; +is_ipv6($.) -> true; +is_ipv6(Char) -> is_hex_digit(Char). + + +-spec parse_ipv6_bin_end(binary(), uri_map()) -> {binary(), uri_map()}. +parse_ipv6_bin_end(?STRING_REST($:, Rest), URI) -> + {T, URI1} = parse_port(Rest, URI), + H = calculate_parsed_host_port(Rest, T), + Port = get_port(H), + {Rest, URI1#{port => Port}}; +parse_ipv6_bin_end(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => decode_path(?STRING_REST($/, Path))}}; +parse_ipv6_bin_end(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_ipv6_bin_end(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_ipv6_bin_end(?STRING_REST(Char, Rest), URI) -> + case is_ipv6(Char) of + true -> parse_ipv6_bin_end(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_ipv6_bin_end(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + +-spec validate_ipv6_address(list()) -> list(). +validate_ipv6_address(Addr) -> + case inet:parse_ipv6strict_address(Addr) of + {ok, _} -> Addr; + {error, _} -> throw({error,invalid_uri,Addr}) + end. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.2.2. Port] +%% +%% The port subcomponent of authority is designated by an optional port +%% number in decimal following the host and delimited from it by a +%% single colon (":") character. +%% +%% port = *DIGIT +%%------------------------------------------------------------------------- +-spec parse_port(binary(), uri_map()) -> {binary(), uri_map()}. +parse_port(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => decode_path(?STRING_REST($/, Path))}}; +parse_port(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => decode_query(Query)}}; +parse_port(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_port(?STRING_REST(Char, Rest), URI) -> + case is_digit(Char) of + true -> parse_port(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_port(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.4. Query] +%% +%% The query component contains non-hierarchical data that, along with +%% data in the path component (Section 3.3), serves to identify a +%% resource within the scope of the URI's scheme and naming authority +%% (if any). The query component is indicated by the first question +%% mark ("?") character and terminated by a number sign ("#") character +%% or by the end of the URI. +%% +%% query = *( pchar / "/" / "?" ) +%%------------------------------------------------------------------------- +-spec parse_query(binary(), uri_map()) -> {binary(), uri_map()}. +parse_query(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => decode_fragment(Fragment)}}; +parse_query(?STRING_REST(Char, Rest), URI) -> + case is_query(Char) of + true -> parse_query(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_query(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%% Check if char is allowed in query +-spec is_query(char()) -> boolean(). +is_query($/) -> true; +is_query($?) -> true; +is_query(Char) -> is_pchar(Char). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.5. Fragment] +%% +%% The fragment identifier component of a URI allows indirect +%% identification of a secondary resource by reference to a primary +%% resource and additional identifying information. +%% +%% fragment = *( pchar / "/" / "?" ) +%%------------------------------------------------------------------------- +-spec parse_fragment(binary(), uri_map()) -> {binary(), uri_map()}. +parse_fragment(?STRING_REST(Char, Rest), URI) -> + case is_fragment(Char) of + true -> parse_fragment(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_fragment(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%% Check if char is allowed in fragment +-spec is_fragment(char()) -> boolean(). +is_fragment($/) -> true; +is_fragment($?) -> true; +is_fragment(Char) -> is_pchar(Char). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 2.2. Reserved Characters] +%% +%% reserved = gen-delims / sub-delims +%% +%% gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@" +%% +%% sub-delims = "!" / "$" / "&" / "'" / "(" / ")" +%% / "*" / "+" / "," / ";" / "=" +%% +%%------------------------------------------------------------------------- + +%% Check if char is sub-delim. +-spec is_sub_delim(char()) -> boolean(). +is_sub_delim($!) -> true; +is_sub_delim($$) -> true; +is_sub_delim($&) -> true; +is_sub_delim($') -> true; +is_sub_delim($() -> true; +is_sub_delim($)) -> true; + +is_sub_delim($*) -> true; +is_sub_delim($+) -> true; +is_sub_delim($,) -> true; +is_sub_delim($;) -> true; +is_sub_delim($=) -> true; +is_sub_delim(_) -> false. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 2.3. Unreserved Characters] +%% +%% unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" +%% +%%------------------------------------------------------------------------- +-spec is_unreserved(char()) -> boolean(). +is_unreserved($-) -> true; +is_unreserved($.) -> true; +is_unreserved($_) -> true; +is_unreserved($~) -> true; +is_unreserved(Char) -> is_alpha(Char) orelse is_digit(Char). + +-spec is_alpha(char()) -> boolean(). +is_alpha(C) + when $A =< C, C =< $Z; + $a =< C, C =< $z -> true; +is_alpha(_) -> false. + +-spec is_digit(char()) -> boolean(). +is_digit(C) + when $0 =< C, C =< $9 -> true; +is_digit(_) -> false. + +-spec is_hex_digit(char()) -> boolean(). +is_hex_digit(C) + when $0 =< C, C =< $9;$a =< C, C =< $f;$A =< C, C =< $F -> true; +is_hex_digit(_) -> false. + + +%% Remove enclosing brackets from binary +-spec remove_brackets(binary()) -> binary(). +remove_brackets(<<$[/utf8, Rest/binary>>) -> + {H,T} = split_binary(Rest, byte_size(Rest) - 1), + case T =:= <<$]/utf8>> of + true -> H; + false -> Rest + end; +remove_brackets(Addr) -> Addr. + + +%%------------------------------------------------------------------------- +%% Helper functions for calculating the parsed binary. +%%------------------------------------------------------------------------- +-spec calculate_parsed_scheme(binary(), binary()) -> binary(). +calculate_parsed_scheme(Input, <<>>) -> + strip_last_char(Input, [$:]); +calculate_parsed_scheme(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +-spec calculate_parsed_part(binary(), binary()) -> binary(). +calculate_parsed_part(Input, <<>>) -> + strip_last_char(Input, [$?,$#]); +calculate_parsed_part(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +-spec calculate_parsed_userinfo(binary(), binary()) -> binary(). +calculate_parsed_userinfo(Input, <<>>) -> + strip_last_char(Input, [$?,$#,$@]); +calculate_parsed_userinfo(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +-spec calculate_parsed_host_port(binary(), binary()) -> binary(). +calculate_parsed_host_port(Input, <<>>) -> + strip_last_char(Input, [$:,$?,$#,$/]); +calculate_parsed_host_port(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +calculate_parsed_query_fragment(Input, <<>>) -> + strip_last_char(Input, [$#]); +calculate_parsed_query_fragment(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +get_port(<<>>) -> + undefined; +get_port(B) -> + try binary_to_integer(B) + catch + error:badarg -> + throw({error, invalid_uri, B}) + end. + + +%% Strip last char if it is in list +%% +%% This function is optimized for speed: parse/1 is about 10% faster than +%% with an alternative implementation based on lists and sets. +strip_last_char(<<>>, _) -> <<>>; +strip_last_char(Input, [C0]) -> + case binary:last(Input) of + C0 -> + init_binary(Input); + _Else -> + Input + end; +strip_last_char(Input, [C0,C1]) -> + case binary:last(Input) of + C0 -> + init_binary(Input); + C1 -> + init_binary(Input); + _Else -> + Input + end; +strip_last_char(Input, [C0,C1,C2]) -> + case binary:last(Input) of + C0 -> + init_binary(Input); + C1 -> + init_binary(Input); + C2 -> + init_binary(Input); + _Else -> + Input + end; +strip_last_char(Input, [C0,C1,C2,C3]) -> + case binary:last(Input) of + C0 -> + init_binary(Input); + C1 -> + init_binary(Input); + C2 -> + init_binary(Input); + C3 -> + init_binary(Input); + _Else -> + Input + end. + + +%% Get parsed binary +get_parsed_binary(Input, Unparsed) -> + {First, _} = split_binary(Input, byte_size(Input) - byte_size_exl_head(Unparsed)), + First. + + +%% Return all bytes of the binary except the last one. The binary must be non-empty. +init_binary(B) -> + {Init, _} = + split_binary(B, byte_size(B) - 1), + Init. + + +%% Returns the size of a binary exluding the first element. +%% Used in calls to split_binary(). +-spec byte_size_exl_head(binary()) -> number(). +byte_size_exl_head(<<>>) -> 0; +byte_size_exl_head(Binary) -> byte_size(Binary) + 1. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 2.1. Percent-Encoding] +%% +%% A percent-encoding mechanism is used to represent a data octet in a +%% component when that octet's corresponding character is outside the +%% allowed set or is being used as a delimiter of, or within, the +%% component. A percent-encoded octet is encoded as a character +%% triplet, consisting of the percent character "%" followed by the two +%% hexadecimal digits representing that octet's numeric value. For +%% example, "%20" is the percent-encoding for the binary octet +%% "00100000" (ABNF: %x20), which in US-ASCII corresponds to the space +%% character (SP). Section 2.4 describes when percent-encoding and +%% decoding is applied. +%% +%% pct-encoded = "%" HEXDIG HEXDIG +%%------------------------------------------------------------------------- +-spec decode_userinfo(binary()) -> binary(). +decode_userinfo(Cs) -> + check_utf8(decode(Cs, fun is_userinfo/1, <<>>)). + +-spec decode_host(binary()) -> binary(). +decode_host(Cs) -> + check_utf8(decode(Cs, fun is_host/1, <<>>)). + +-spec decode_path(binary()) -> binary(). +decode_path(Cs) -> + check_utf8(decode(Cs, fun is_path/1, <<>>)). + +-spec decode_query(binary()) -> binary(). +decode_query(Cs) -> + check_utf8(decode(Cs, fun is_query/1, <<>>)). + +-spec decode_fragment(binary()) -> binary(). +decode_fragment(Cs) -> + check_utf8(decode(Cs, fun is_fragment/1, <<>>)). + + +%% Returns Cs if it is utf8 encoded. +check_utf8(Cs) -> + case unicode:characters_to_list(Cs) of + {incomplete,_,_} -> + throw({error,invalid_utf8,Cs}); + {error,_,_} -> + throw({error,invalid_utf8,Cs}); + _ -> Cs + end. + +%%------------------------------------------------------------------------- +%% Percent-encode +%%------------------------------------------------------------------------- + +%% Only validates as scheme cannot have percent-encoded characters +-spec encode_scheme(list()|binary()) -> list() | binary(). +encode_scheme([]) -> + throw({error,invalid_scheme,""}); +encode_scheme(<<>>) -> + throw({error,invalid_scheme,<<>>}); +encode_scheme(Scheme) -> + case validate_scheme(Scheme) of + true -> Scheme; + false -> throw({error,invalid_scheme,Scheme}) + end. + +-spec encode_userinfo(list()|binary()) -> list() | binary(). +encode_userinfo(Cs) -> + encode(Cs, fun is_userinfo/1). + +-spec encode_host(list()|binary()) -> list() | binary(). +encode_host(Cs) -> + case classify_host(Cs) of + regname -> Cs; + ipv4 -> Cs; + ipv6 -> bracket_ipv6(Cs); + other -> encode(Cs, fun is_reg_name/1) + end. + +-spec encode_path(list()|binary()) -> list() | binary(). +encode_path(Cs) -> + encode(Cs, fun is_path/1). + +-spec encode_query(list()|binary()) -> list() | binary(). +encode_query(Cs) -> + encode(Cs, fun is_query/1). + +-spec encode_fragment(list()|binary()) -> list() | binary(). +encode_fragment(Cs) -> + encode(Cs, fun is_fragment/1). + +%%------------------------------------------------------------------------- +%% Helper funtions for percent-decode +%%------------------------------------------------------------------------- +decode(<<$%,C0,C1,Cs/binary>>, Fun, Acc) -> + case is_hex_digit(C0) andalso is_hex_digit(C1) of + true -> + B = ?HEX2DEC(C0)*16+?HEX2DEC(C1), + decode(Cs, Fun, <<Acc/binary, B>>); + false -> throw({error,invalid_percent_encoding,<<$%,C0,C1>>}) + end; +decode(<<C,Cs/binary>>, Fun, Acc) -> + case Fun(C) of + true -> decode(Cs, Fun, <<Acc/binary, C>>); + false -> throw({error,invalid_percent_encoding,<<C,Cs/binary>>}) + end; +decode(<<>>, _Fun, Acc) -> + Acc. + +%% Check if char is allowed in host +-spec is_host(char()) -> boolean(). +is_host($:) -> true; +is_host(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + +%% Check if char is allowed in path +-spec is_path(char()) -> boolean(). +is_path($/) -> true; +is_path(Char) -> is_pchar(Char). + + +%%------------------------------------------------------------------------- +%% Helper functions for percent-encode +%%------------------------------------------------------------------------- +-spec encode(list()|binary(), fun()) -> list() | binary(). +encode(Component, Fun) when is_list(Component) -> + B = unicode:characters_to_binary(Component), + unicode:characters_to_list(encode(B, Fun, <<>>)); +encode(Component, Fun) when is_binary(Component) -> + encode(Component, Fun, <<>>). +%% +encode(<<Char/utf8, Rest/binary>>, Fun, Acc) -> + C = encode_codepoint_binary(Char, Fun), + encode(Rest, Fun, <<Acc/binary,C/binary>>); +encode(<<Char, Rest/binary>>, _Fun, _Acc) -> + throw({error,invalid_input,<<Char,Rest/binary>>}); +encode(<<>>, _Fun, Acc) -> + Acc. + + +-spec encode_codepoint_binary(integer(), fun()) -> binary(). +encode_codepoint_binary(C, Fun) -> + case Fun(C) of + false -> percent_encode_binary(C); + true -> <<C>> + end. + + +-spec percent_encode_binary(integer()) -> binary(). +percent_encode_binary(Code) -> + percent_encode_binary(<<Code/utf8>>, <<>>). + + +percent_encode_binary(<<A:4,B:4,Rest/binary>>, Acc) -> + percent_encode_binary(Rest, <<Acc/binary,$%,(?DEC2HEX(A)),(?DEC2HEX(B))>>); +percent_encode_binary(<<>>, Acc) -> + Acc. + + +%%------------------------------------------------------------------------- +%%------------------------------------------------------------------------- +validate_scheme([]) -> true; +validate_scheme([H|T]) -> + case is_scheme(H) of + true -> validate_scheme(T); + false -> false + end; +validate_scheme(<<>>) -> true; +validate_scheme(<<H, Rest/binary>>) -> + case is_scheme(H) of + true -> validate_scheme(Rest); + false -> false + end. + + +%%------------------------------------------------------------------------- +%% Classifies hostname into the following categories: +%% regname, ipv4 - address does not contain reserved characters to be +%% percent-encoded +%% ipv6 - address does not contain reserved characters but it shall be +%% encolsed in brackets +%% other - address shall be percent-encoded +%%------------------------------------------------------------------------- +classify_host([]) -> other; +classify_host(Addr) when is_binary(Addr) -> + A = unicode:characters_to_list(Addr), + classify_host_ipv6(A); +classify_host(Addr) -> + classify_host_ipv6(Addr). + +classify_host_ipv6(Addr) -> + case is_ipv6_address(Addr) of + true -> ipv6; + false -> classify_host_ipv4(Addr) + end. + +classify_host_ipv4(Addr) -> + case is_ipv4_address(Addr) of + true -> ipv4; + false -> classify_host_regname(Addr) + end. + +classify_host_regname([]) -> regname; +classify_host_regname([H|T]) -> + case is_reg_name(H) of + true -> classify_host_regname(T); + false -> other + end. + +is_ipv4_address(Addr) -> + case inet:parse_ipv4strict_address(Addr) of + {ok, _} -> true; + {error, _} -> false + end. + +is_ipv6_address(Addr) -> + case inet:parse_ipv6strict_address(Addr) of + {ok, _} -> true; + {error, _} -> false + end. + +bracket_ipv6(Addr) when is_binary(Addr) -> + concat(<<$[,Addr/binary>>,<<$]>>); +bracket_ipv6(Addr) when is_list(Addr) -> + [$[|Addr] ++ "]". + + +%%------------------------------------------------------------------------- +%% Helper funtions for recompose +%%------------------------------------------------------------------------- + +%%------------------------------------------------------------------------- +%% Checks if input Map has valid combination of fields that can be +%% recomposed into a URI. +%% +%% The implementation is based on a decision tree that fulfills the +%% following rules: +%% - 'path' shall always be present in the input map +%% URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ] +%% hier-part = "//" authority path-abempty +%% / path-absolute +%% / path-rootless +%% / path-empty +%% - 'host' shall be present in the input map when 'path' starts with +%% two slashes ("//") +%% path = path-abempty ; begins with "/" or is empty +%% / path-absolute ; begins with "/" but not "//" +%% / path-noscheme ; begins with a non-colon segment +%% / path-rootless ; begins with a segment +%% / path-empty ; zero characters +%% path-abempty = *( "/" segment ) +%% segment = *pchar +%% - 'host' shall be present if userinfo or port is present in input map +%% authority = [ userinfo "@" ] host [ ":" port ] +%% - All fields shall be valid (scheme, userinfo, host, port, path, query +%% or fragment). +%%------------------------------------------------------------------------- +is_valid_map(#{path := Path} = Map) -> + ((starts_with_two_slash(Path) andalso is_valid_map_host(Map)) + orelse + (maps:is_key(userinfo, Map) andalso is_valid_map_host(Map)) + orelse + (maps:is_key(port, Map) andalso is_valid_map_host(Map)) + orelse + all_fields_valid(Map)); +is_valid_map(#{}) -> + false. + + +is_valid_map_host(Map) -> + maps:is_key(host, Map) andalso all_fields_valid(Map). + + +all_fields_valid(Map) -> + Fun = fun(scheme, _, Acc) -> Acc; + (userinfo, _, Acc) -> Acc; + (host, _, Acc) -> Acc; + (port, _, Acc) -> Acc; + (path, _, Acc) -> Acc; + (query, _, Acc) -> Acc; + (fragment, _, Acc) -> Acc; + (_, _, _) -> false + end, + maps:fold(Fun, true, Map). + + +starts_with_two_slash([$/,$/|_]) -> + true; +starts_with_two_slash(?STRING_REST("//", _)) -> + true; +starts_with_two_slash(_) -> false. + + +update_scheme(#{scheme := Scheme}, _) -> + add_colon_postfix(encode_scheme(Scheme)); +update_scheme(#{}, _) -> + empty. + + +update_userinfo(#{userinfo := Userinfo}, empty) -> + add_auth_prefix(encode_userinfo(Userinfo)); +update_userinfo(#{userinfo := Userinfo}, URI) -> + concat(URI,add_auth_prefix(encode_userinfo(Userinfo))); +update_userinfo(#{}, empty) -> + empty; +update_userinfo(#{}, URI) -> + URI. + + +update_host(#{host := Host}, empty) -> + add_auth_prefix(encode_host(Host)); +update_host(#{host := Host} = Map, URI) -> + concat(URI,add_host_prefix(Map, encode_host(Host))); +update_host(#{}, empty) -> + empty; +update_host(#{}, URI) -> + URI. + + +%% URI cannot be empty for ports. E.g. ":8080" is not a valid URI +update_port(#{port := undefined}, URI) -> + concat(URI, <<":">>); +update_port(#{port := Port}, URI) -> + concat(URI,add_colon(encode_port(Port))); +update_port(#{}, URI) -> + URI. + + +update_path(#{path := Path}, empty) -> + encode_path(Path); +update_path(#{path := Path}, URI) -> + concat(URI,encode_path(Path)); +update_path(#{}, empty) -> + empty; +update_path(#{}, URI) -> + URI. + + +update_query(#{query := Query}, empty) -> + encode_query(Query); +update_query(#{query := Query}, URI) -> + concat(URI,add_question_mark(encode_query(Query))); +update_query(#{}, empty) -> + empty; +update_query(#{}, URI) -> + URI. + + +update_fragment(#{fragment := Fragment}, empty) -> + add_hashmark(encode_fragment(Fragment)); +update_fragment(#{fragment := Fragment}, URI) -> + concat(URI,add_hashmark(encode_fragment(Fragment))); +update_fragment(#{}, empty) -> + ""; +update_fragment(#{}, URI) -> + URI. + +%%------------------------------------------------------------------------- +%% Concatenates its arguments that can be lists and binaries. +%% The result is a list if at least one of its argument is a list and +%% binary otherwise. +%%------------------------------------------------------------------------- +concat(A, B) when is_binary(A), is_binary(B) -> + <<A/binary, B/binary>>; +concat(A, B) when is_binary(A), is_list(B) -> + unicode:characters_to_list(A) ++ B; +concat(A, B) when is_list(A) -> + A ++ maybe_to_list(B). + +add_hashmark(Comp) when is_binary(Comp) -> + <<$#, Comp/binary>>; +add_hashmark(Comp) when is_list(Comp) -> + [$#|Comp]. + +add_question_mark(Comp) when is_binary(Comp) -> + <<$?, Comp/binary>>; +add_question_mark(Comp) when is_list(Comp) -> + [$?|Comp]. + +add_colon(Comp) when is_binary(Comp) -> + <<$:, Comp/binary>>. + +add_colon_postfix(Comp) when is_binary(Comp) -> + <<Comp/binary,$:>>; +add_colon_postfix(Comp) when is_list(Comp) -> + Comp ++ ":". + +add_auth_prefix(Comp) when is_binary(Comp) -> + <<"//", Comp/binary>>; +add_auth_prefix(Comp) when is_list(Comp) -> + [$/,$/|Comp]. + +add_host_prefix(#{userinfo := _}, Host) when is_binary(Host) -> + <<$@,Host/binary>>; +add_host_prefix(#{}, Host) when is_binary(Host) -> + <<"//",Host/binary>>; +add_host_prefix(#{userinfo := _}, Host) when is_list(Host) -> + [$@|Host]; +add_host_prefix(#{}, Host) when is_list(Host) -> + [$/,$/|Host]. + +maybe_to_list(Comp) when is_binary(Comp) -> unicode:characters_to_list(Comp); +maybe_to_list(Comp) -> Comp. + +encode_port(Port) -> + integer_to_binary(Port). + +%%------------------------------------------------------------------------- +%% Helper functions for transcode +%%------------------------------------------------------------------------- + +%%------------------------------------------------------------------------- +%% uri_string:transcode(<<"x%00%00%00%F6"/utf32>>). +%% 1. Convert (transcode/2) input to list form (list of unicode codepoints) +%% "x%00%00%00%F6" +%% 2. Accumulate characters until percent-encoded segment (transcode/4). +%% Acc = "x" +%% 3. Convert percent-encoded triplets to binary form (transcode_pct/4) +%% <<0,0,0,246>> +%% 4. Transcode in-encoded binary to out-encoding (utf32 -> utf8): +%% <<195,182>> +%% 5. Percent-encode out-encoded binary: +%% <<"%C3%B6"/utf8>> = <<37,67,51,37,66,54>> +%% 6. Convert binary to list form, reverse it and append the accumulator +%% "6B%3C%" + "x" +%% 7. Reverse Acc and return it +%%------------------------------------------------------------------------- +transcode([$%,_C0,_C1|_Rest] = L, Acc, InEnc, OutEnc) -> + transcode_pct(L, Acc, <<>>, InEnc, OutEnc); +transcode([_C|_Rest] = L, Acc, InEnc, OutEnc) -> + transcode(L, Acc, [], InEnc, OutEnc). +%% +transcode([$%,_C0,_C1|_Rest] = L, Acc, List, InEncoding, OutEncoding) -> + transcode_pct(L, List ++ Acc, <<>>, InEncoding, OutEncoding); +transcode([C|Rest], Acc, List, InEncoding, OutEncoding) -> + transcode(Rest, Acc, [C|List], InEncoding, OutEncoding); +transcode([], Acc, List, _InEncoding, _OutEncoding) -> + lists:reverse(List ++ Acc). + + +%% Transcode percent-encoded segment +transcode_pct([$%,C0,C1|Rest] = L, Acc, B, InEncoding, OutEncoding) -> + case is_hex_digit(C0) andalso is_hex_digit(C1) of + true -> + Int = ?HEX2DEC(C0)*16+?HEX2DEC(C1), + transcode_pct(Rest, Acc, <<B/binary, Int>>, InEncoding, OutEncoding); + false -> throw({error, invalid_percent_encoding,L}) + end; +transcode_pct([_C|_Rest] = L, Acc, B, InEncoding, OutEncoding) -> + OutBinary = convert_to_binary(B, InEncoding, OutEncoding), + PctEncUtf8 = percent_encode_segment(OutBinary), + Out = lists:reverse(convert_to_list(PctEncUtf8, utf8)), + transcode(L, Out ++ Acc, [], InEncoding, OutEncoding); +transcode_pct([], Acc, B, InEncoding, OutEncoding) -> + OutBinary = convert_to_binary(B, InEncoding, OutEncoding), + PctEncUtf8 = percent_encode_segment(OutBinary), + Out = convert_to_list(PctEncUtf8, utf8), + lists:reverse(Acc) ++ Out. + + +%% Convert to binary +convert_to_binary(Binary, InEncoding, OutEncoding) -> + case unicode:characters_to_binary(Binary, InEncoding, OutEncoding) of + {error, _List, RestData} -> + throw({error, invalid_input, RestData}); + {incomplete, _List, RestData} -> + throw({error, invalid_input, RestData}); + Result -> + Result + end. + + +%% Convert to list +convert_to_list(Binary, InEncoding) -> + case unicode:characters_to_list(Binary, InEncoding) of + {error, _List, RestData} -> + throw({error, invalid_input, RestData}); + {incomplete, _List, RestData} -> + throw({error, invalid_input, RestData}); + Result -> + Result + end. + + +%% Flatten input list +flatten_list([], _) -> + []; +flatten_list(L, InEnc) -> + flatten_list(L, InEnc, []). +%% +flatten_list([H|T], InEnc, Acc) when is_binary(H) -> + L = convert_to_list(H, InEnc), + flatten_list(T, InEnc, lists:reverse(L) ++ Acc); +flatten_list([H|T], InEnc, Acc) when is_list(H) -> + flatten_list(H ++ T, InEnc, Acc); +flatten_list([H|T], InEnc, Acc) -> + flatten_list(T, InEnc, [H|Acc]); +flatten_list([], _InEnc, Acc) -> + lists:reverse(Acc); +flatten_list(Arg, _, _) -> + throw({error, invalid_input, Arg}). + + +percent_encode_segment(Segment) -> + percent_encode_binary(Segment, <<>>). + + +%%------------------------------------------------------------------------- +%% Helper functions for compose_query +%%------------------------------------------------------------------------- + +%% Returns separator to be used between key-value pairs +get_separator(L) when length(L) =:= 0 -> + <<>>; +get_separator(_L) -> + <<"&">>. + + +%% HTML5 - 4.10.22.6 URL-encoded form data - encoding +form_urlencode(Cs, [{encoding, latin1}]) when is_list(Cs) -> + B = convert_to_binary(Cs, utf8, utf8), + html5_byte_encode(base10_encode(B)); +form_urlencode(Cs, [{encoding, latin1}]) when is_binary(Cs) -> + html5_byte_encode(base10_encode(Cs)); +form_urlencode(Cs, [{encoding, Encoding}]) + when is_list(Cs), Encoding =:= utf8; Encoding =:= unicode -> + B = convert_to_binary(Cs, utf8, Encoding), + html5_byte_encode(B); +form_urlencode(Cs, [{encoding, Encoding}]) + when is_binary(Cs), Encoding =:= utf8; Encoding =:= unicode -> + html5_byte_encode(Cs); +form_urlencode(Cs, [{encoding, Encoding}]) when is_list(Cs); is_binary(Cs) -> + throw({error,invalid_encoding, Encoding}); +form_urlencode(Cs, _) -> + throw({error,invalid_input, Cs}). + + +%% For each character in the entry's name and value that cannot be expressed using +%% the selected character encoding, replace the character by a string consisting of +%% a U+0026 AMPERSAND character (&), a "#" (U+0023) character, one or more ASCII +%% digits representing the Unicode code point of the character in base ten, and +%% finally a ";" (U+003B) character. +base10_encode(Cs) -> + base10_encode(Cs, <<>>). +%% +base10_encode(<<>>, Acc) -> + Acc; +base10_encode(<<H/utf8,T/binary>>, Acc) when H > 255 -> + Base10 = convert_to_binary(integer_to_list(H,10), utf8, utf8), + base10_encode(T, <<Acc/binary,"&#",Base10/binary,$;>>); +base10_encode(<<H/utf8,T/binary>>, Acc) -> + base10_encode(T, <<Acc/binary,H>>). + + +html5_byte_encode(B) -> + html5_byte_encode(B, <<>>). +%% +html5_byte_encode(<<>>, Acc) -> + Acc; +html5_byte_encode(<<$ ,T/binary>>, Acc) -> + html5_byte_encode(T, <<Acc/binary,$+>>); +html5_byte_encode(<<H,T/binary>>, Acc) -> + case is_url_char(H) of + true -> + html5_byte_encode(T, <<Acc/binary,H>>); + false -> + <<A:4,B:4>> = <<H>>, + html5_byte_encode(T, <<Acc/binary,$%,(?DEC2HEX(A)),(?DEC2HEX(B))>>) + end; +html5_byte_encode(H, _Acc) -> + throw({error,invalid_input, H}). + + +%% Return true if input char can appear in form-urlencoded string +%% Allowed chararacters: +%% 0x2A, 0x2D, 0x2E, 0x30 to 0x39, 0x41 to 0x5A, +%% 0x5F, 0x61 to 0x7A +is_url_char(C) + when C =:= 16#2A; C =:= 16#2D; + C =:= 16#2E; C =:= 16#5F; + 16#30 =< C, C =< 16#39; + 16#41 =< C, C =< 16#5A; + 16#61 =< C, C =< 16#7A -> true; +is_url_char(_) -> false. + + +%%------------------------------------------------------------------------- +%% Helper functions for dissect_query +%%------------------------------------------------------------------------- +dissect_query_key(<<$=,T/binary>>, IsList, Acc, Key, Value) -> + dissect_query_value(T, IsList, Acc, Key, Value); +dissect_query_key(<<"&#",T/binary>>, IsList, Acc, Key, Value) -> + dissect_query_key(T, IsList, Acc, <<Key/binary,"&#">>, Value); +dissect_query_key(<<$&,_T/binary>>, _IsList, _Acc, _Key, _Value) -> + throw({error, missing_value, "&"}); +dissect_query_key(<<H,T/binary>>, IsList, Acc, Key, Value) -> + dissect_query_key(T, IsList, Acc, <<Key/binary,H>>, Value); +dissect_query_key(B, _, _, _, _) -> + throw({error, missing_value, B}). + + +dissect_query_value(<<$&,T/binary>>, IsList, Acc, Key, Value) -> + K = form_urldecode(IsList, Key), + V = form_urldecode(IsList, Value), + dissect_query_key(T, IsList, [{K,V}|Acc], <<>>, <<>>); +dissect_query_value(<<H,T/binary>>, IsList, Acc, Key, Value) -> + dissect_query_value(T, IsList, Acc, Key, <<Value/binary,H>>); +dissect_query_value(<<>>, IsList, Acc, Key, Value) -> + K = form_urldecode(IsList, Key), + V = form_urldecode(IsList, Value), + lists:reverse([{K,V}|Acc]). + + +%% Form-urldecode input based on RFC 1866 [8.2.1] +form_urldecode(true, B) -> + Result = base10_decode(form_urldecode(B, <<>>)), + convert_to_list(Result, utf8); +form_urldecode(false, B) -> + base10_decode(form_urldecode(B, <<>>)); +form_urldecode(<<>>, Acc) -> + Acc; +form_urldecode(<<$+,T/binary>>, Acc) -> + form_urldecode(T, <<Acc/binary,$ >>); +form_urldecode(<<$%,C0,C1,T/binary>>, Acc) -> + case is_hex_digit(C0) andalso is_hex_digit(C1) of + true -> + V = ?HEX2DEC(C0)*16+?HEX2DEC(C1), + form_urldecode(T, <<Acc/binary, V>>); + false -> + L = convert_to_list(<<$%,C0,C1,T/binary>>, utf8), + throw({error, invalid_percent_encoding, L}) + end; +form_urldecode(<<H/utf8,T/binary>>, Acc) -> + form_urldecode(T, <<Acc/binary,H/utf8>>); +form_urldecode(<<H,_/binary>>, _Acc) -> + throw({error, invalid_character, [H]}). + +base10_decode(Cs) -> + base10_decode(Cs, <<>>). +% +base10_decode(<<>>, Acc) -> + Acc; +base10_decode(<<"&#",T/binary>>, Acc) -> + base10_decode_unicode(T, Acc); +base10_decode(<<H/utf8,T/binary>>, Acc) -> + base10_decode(T,<<Acc/binary,H/utf8>>); +base10_decode(<<H,_/binary>>, _) -> + throw({error, invalid_input, [H]}). + + +base10_decode_unicode(B, Acc) -> + base10_decode_unicode(B, 0, Acc). +%% +base10_decode_unicode(<<H/utf8,T/binary>>, Codepoint, Acc) when $0 =< H, H =< $9 -> + Res = Codepoint * 10 + (H - $0), + base10_decode_unicode(T, Res, Acc); +base10_decode_unicode(<<$;,T/binary>>, Codepoint, Acc) -> + base10_decode(T, <<Acc/binary,Codepoint/utf8>>); +base10_decode_unicode(<<H,_/binary>>, _, _) -> + throw({error, invalid_input, [H]}). + + +%%------------------------------------------------------------------------- +%% Helper functions for normalize +%%------------------------------------------------------------------------- + +%% 6.2.2.1. Case Normalization +normalize_case(#{scheme := Scheme, host := Host} = Map) -> + Map#{scheme => to_lower(Scheme), + host => to_lower(Host)}; +normalize_case(#{host := Host} = Map) -> + Map#{host => to_lower(Host)}; +normalize_case(#{scheme := Scheme} = Map) -> + Map#{scheme => to_lower(Scheme)}; +normalize_case(#{} = Map) -> + Map. + + +to_lower(Cs) when is_list(Cs) -> + B = convert_to_binary(Cs, utf8, utf8), + convert_to_list(to_lower(B), utf8); +to_lower(Cs) when is_binary(Cs) -> + to_lower(Cs, <<>>). +%% +to_lower(<<C,Cs/binary>>, Acc) when $A =< C, C =< $Z -> + to_lower(Cs, <<Acc/binary,(C + 32)>>); +to_lower(<<C,Cs/binary>>, Acc) -> + to_lower(Cs, <<Acc/binary,C>>); +to_lower(<<>>, Acc) -> + Acc. + + +%% 6.2.2.3. Path Segment Normalization +%% 5.2.4. Remove Dot Segments +normalize_path_segment(Map) -> + Path = maps:get(path, Map, undefined), + Map#{path => remove_dot_segments(Path)}. + + +remove_dot_segments(Path) when is_binary(Path) -> + remove_dot_segments(Path, <<>>); +remove_dot_segments(Path) when is_list(Path) -> + B = convert_to_binary(Path, utf8, utf8), + B1 = remove_dot_segments(B, <<>>), + convert_to_list(B1, utf8). +%% +remove_dot_segments(<<>>, Output) -> + Output; +remove_dot_segments(<<"../",T/binary>>, Output) -> + remove_dot_segments(T, Output); +remove_dot_segments(<<"./",T/binary>>, Output) -> + remove_dot_segments(T, Output); +remove_dot_segments(<<"/./",T/binary>>, Output) -> + remove_dot_segments(<<$/,T/binary>>, Output); +remove_dot_segments(<<"/.">>, Output) -> + remove_dot_segments(<<$/>>, Output); +remove_dot_segments(<<"/../",T/binary>>, Output) -> + Out1 = remove_last_segment(Output), + remove_dot_segments(<<$/,T/binary>>, Out1); +remove_dot_segments(<<"/..">>, Output) -> + Out1 = remove_last_segment(Output), + remove_dot_segments(<<$/>>, Out1); +remove_dot_segments(<<$.>>, Output) -> + remove_dot_segments(<<>>, Output); +remove_dot_segments(<<"..">>, Output) -> + remove_dot_segments(<<>>, Output); +remove_dot_segments(Input, Output) -> + {First, Rest} = first_path_segment(Input), + remove_dot_segments(Rest, <<Output/binary,First/binary>>). + + +first_path_segment(Input) -> + F = first_path_segment(Input, <<>>), + split_binary(Input, byte_size(F)). +%% +first_path_segment(<<$/,T/binary>>, Acc) -> + first_path_segment_end(<<T/binary>>, <<Acc/binary,$/>>); +first_path_segment(<<C,T/binary>>, Acc) -> + first_path_segment_end(<<T/binary>>, <<Acc/binary,C>>). + + +first_path_segment_end(<<>>, Acc) -> + Acc; +first_path_segment_end(<<$/,_/binary>>, Acc) -> + Acc; +first_path_segment_end(<<C,T/binary>>, Acc) -> + first_path_segment_end(<<T/binary>>, <<Acc/binary,C>>). + + +remove_last_segment(<<>>) -> + <<>>; +remove_last_segment(B) -> + {Init, Last} = split_binary(B, byte_size(B) - 1), + case Last of + <<$/>> -> + Init; + _Char -> + remove_last_segment(Init) + end. + + +%% RFC 3986, 6.2.3. Scheme-Based Normalization +normalize_scheme_based(Map) -> + Scheme = maps:get(scheme, Map, undefined), + Port = maps:get(port, Map, undefined), + Path= maps:get(path, Map, undefined), + normalize_scheme_based(Map, Scheme, Port, Path). +%% +normalize_scheme_based(Map, Scheme, Port, Path) + when Scheme =:= "http"; Scheme =:= <<"http">> -> + normalize_http(Map, Port, Path); +normalize_scheme_based(Map, Scheme, Port, Path) + when Scheme =:= "https"; Scheme =:= <<"https">> -> + normalize_https(Map, Port, Path); +normalize_scheme_based(Map, Scheme, Port, _Path) + when Scheme =:= "ftp"; Scheme =:= <<"ftp">> -> + normalize_ftp(Map, Port); +normalize_scheme_based(Map, Scheme, Port, _Path) + when Scheme =:= "ssh"; Scheme =:= <<"ssh">> -> + normalize_ssh_sftp(Map, Port); +normalize_scheme_based(Map, Scheme, Port, _Path) + when Scheme =:= "sftp"; Scheme =:= <<"sftp">> -> + normalize_ssh_sftp(Map, Port); +normalize_scheme_based(Map, Scheme, Port, _Path) + when Scheme =:= "tftp"; Scheme =:= <<"tftp">> -> + normalize_tftp(Map, Port); +normalize_scheme_based(Map, _, _, _) -> + Map. + + +normalize_http(Map, Port, Path) -> + M1 = normalize_port(Map, Port, 80), + normalize_http_path(M1, Path). + + +normalize_https(Map, Port, Path) -> + M1 = normalize_port(Map, Port, 443), + normalize_http_path(M1, Path). + + +normalize_ftp(Map, Port) -> + normalize_port(Map, Port, 21). + + +normalize_ssh_sftp(Map, Port) -> + normalize_port(Map, Port, 22). + + +normalize_tftp(Map, Port) -> + normalize_port(Map, Port, 69). + + +normalize_port(Map, Port, Default) -> + case Port of + Default -> + maps:remove(port, Map); + _Else -> + Map + end. + + +normalize_http_path(Map, Path) -> + case Path of + "" -> + Map#{path => "/"}; + <<>> -> + Map#{path => <<"/">>}; + _Else -> + Map + end. diff --git a/lib/stdlib/test/Makefile b/lib/stdlib/test/Makefile index 523cb95065..8490770f3d 100644 --- a/lib/stdlib/test/Makefile +++ b/lib/stdlib/test/Makefile @@ -87,6 +87,7 @@ MODULES= \ timer_simple_SUITE \ unicode_SUITE \ unicode_util_SUITE \ + uri_string_SUITE \ win32reg_SUITE \ y2k_SUITE \ select_SUITE \ diff --git a/lib/stdlib/test/base64_SUITE.erl b/lib/stdlib/test/base64_SUITE.erl index 48b3f5f959..1fc4c3fc0e 100644 --- a/lib/stdlib/test/base64_SUITE.erl +++ b/lib/stdlib/test/base64_SUITE.erl @@ -97,10 +97,9 @@ base64_otp_5635(Config) when is_list(Config) -> <<"===">> = base64:decode(base64:encode("===")), ok. %%------------------------------------------------------------------------- -%% OTP-6279: Guard needed so that function fails in a correct -%% way for faulty input, i.e. function_clause. +%% OTP-6279: Make sure illegal characters are rejected when decoding. base64_otp_6279(Config) when is_list(Config) -> - {'EXIT',{function_clause, _}} = (catch base64:decode("dGVzda==a")), + {'EXIT',_} = (catch base64:decode("dGVzda==a")), ok. %%------------------------------------------------------------------------- %% Encode and decode big binaries. @@ -115,48 +114,61 @@ big(Config) when is_list(Config) -> %%------------------------------------------------------------------------- %% Make sure illegal characters are rejected when decoding. illegal(Config) when is_list(Config) -> - {'EXIT',{function_clause, _}} = (catch base64:decode("()")), + %% A few samples with different error reasons. Nothing can be + %% assumed about the reason for the crash. + {'EXIT',_} = (catch base64:decode("()")), + {'EXIT',_} = (catch base64:decode(<<19:8,20:8,21:8,22:8>>)), + {'EXIT',_} = (catch base64:decode([19,20,21,22])), + {'EXIT',_} = (catch base64:decode_to_string(<<19:8,20:8,21:8,22:8>>)), + {'EXIT',_} = (catch base64:decode_to_string([19,20,21,22])), ok. %%------------------------------------------------------------------------- %% mime_decode and mime_decode_to_string have different implementations -%% so test both with the same input separately. Both functions have -%% the same implementation for binary/string arguments. +%% so test both with the same input separately. %% %% Test base64:mime_decode/1. mime_decode(Config) when is_list(Config) -> + MimeDecode = fun(In) -> + Out = base64:mime_decode(In), + Out = base64:mime_decode(binary_to_list(In)) + end, %% Test correct padding - <<"one">> = base64:mime_decode(<<"b25l">>), - <<"on">> = base64:mime_decode(<<"b24=">>), - <<"o">> = base64:mime_decode(<<"bw==">>), + <<"one">> = MimeDecode(<<"b25l">>), + <<"on">> = MimeDecode(<<"b24=">>), + <<"o">> = MimeDecode(<<"bw==">>), %% Test 1 extra padding - <<"one">> = base64:mime_decode(<<"b25l= =">>), - <<"on">> = base64:mime_decode(<<"b24== =">>), - <<"o">> = base64:mime_decode(<<"bw=== =">>), + <<"one">> = MimeDecode(<<"b25l= =">>), + <<"on">> = MimeDecode(<<"b24== =">>), + <<"o">> = MimeDecode(<<"bw=== =">>), %% Test 2 extra padding - <<"one">> = base64:mime_decode(<<"b25l===">>), - <<"on">> = base64:mime_decode(<<"b24====">>), - <<"o">> = base64:mime_decode(<<"bw=====">>), + <<"one">> = MimeDecode(<<"b25l===">>), + <<"on">> = MimeDecode(<<"b24====">>), + <<"o">> = MimeDecode(<<"bw=====">>), %% Test misc embedded padding - <<"one">> = base64:mime_decode(<<"b2=5l===">>), - <<"on">> = base64:mime_decode(<<"b=24====">>), - <<"o">> = base64:mime_decode(<<"b=w=====">>), + <<"one">> = MimeDecode(<<"b2=5l===">>), + <<"on">> = MimeDecode(<<"b=24====">>), + <<"o">> = MimeDecode(<<"b=w=====">>), %% Test misc white space and illegals with embedded padding - <<"one">> = base64:mime_decode(<<" b~2=\r\n5()l===">>), - <<"on">> = base64:mime_decode(<<"\tb =2\"¤4=¤= ==">>), - <<"o">> = base64:mime_decode(<<"\nb=w=====">>), + <<"one">> = MimeDecode(<<" b~2=\r\n5()l===">>), + <<"on">> = MimeDecode(<<"\tb =2\"¤4=¤= ==">>), + <<"o">> = MimeDecode(<<"\nb=w=====">>), %% Two pads <<"Aladdin:open sesame">> = - base64:mime_decode("QWxhZGRpbjpvc()GVuIHNlc2FtZQ=="), + MimeDecode(<<"QWxhZGRpbjpvc()GVuIHNlc2FtZQ==">>), %% One pad to ignore, followed by more text - <<"Hello World!!">> = base64:mime_decode(<<"SGVsb)(G8gV29ybGQ=h IQ= =">>), + <<"Hello World!!">> = MimeDecode(<<"SGVsb)(G8gV29ybGQ=h IQ= =">>), %% No pad <<"Aladdin:open sesam">> = - base64:mime_decode("QWxhZGRpbjpvcG¤\")(VuIHNlc2Ft"), + MimeDecode(<<"QWxhZGRpbjpvcG¤\")(VuIHNlc2Ft">>), %% Encoded base 64 strings may be divided by non base 64 chars. %% In this cases whitespaces. <<"0123456789!@#0^&*();:<>,. []{}">> = - base64:mime_decode( + MimeDecode( <<"MDEy MzQ1Njc4 \tOSFAIzBeJ \nio)(oKTs6 PD4sLi \r\nBbXXt9">>), + %% Zeroes + <<"012">> = MimeDecode(<<"\000M\000D\000E\000y=\000">>), + <<"o">> = MimeDecode(<<"bw==\000">>), + <<"o">> = MimeDecode(<<"bw=\000=">>), ok. %%------------------------------------------------------------------------- @@ -165,39 +177,48 @@ mime_decode(Config) when is_list(Config) -> %% Test base64:mime_decode_to_string/1. mime_decode_to_string(Config) when is_list(Config) -> + MimeDecodeToString = + fun(In) -> + Out = base64:mime_decode_to_string(In), + Out = base64:mime_decode_to_string(binary_to_list(In)) + end, %% Test correct padding - "one" = base64:mime_decode_to_string(<<"b25l">>), - "on" = base64:mime_decode_to_string(<<"b24=">>), - "o" = base64:mime_decode_to_string(<<"bw==">>), + "one" = MimeDecodeToString(<<"b25l">>), + "on" = MimeDecodeToString(<<"b24=">>), + "o" = MimeDecodeToString(<<"bw==">>), %% Test 1 extra padding - "one" = base64:mime_decode_to_string(<<"b25l= =">>), - "on" = base64:mime_decode_to_string(<<"b24== =">>), - "o" = base64:mime_decode_to_string(<<"bw=== =">>), + "one" = MimeDecodeToString(<<"b25l= =">>), + "on" = MimeDecodeToString(<<"b24== =">>), + "o" = MimeDecodeToString(<<"bw=== =">>), %% Test 2 extra padding - "one" = base64:mime_decode_to_string(<<"b25l===">>), - "on" = base64:mime_decode_to_string(<<"b24====">>), - "o" = base64:mime_decode_to_string(<<"bw=====">>), + "one" = MimeDecodeToString(<<"b25l===">>), + "on" = MimeDecodeToString(<<"b24====">>), + "o" = MimeDecodeToString(<<"bw=====">>), %% Test misc embedded padding - "one" = base64:mime_decode_to_string(<<"b2=5l===">>), - "on" = base64:mime_decode_to_string(<<"b=24====">>), - "o" = base64:mime_decode_to_string(<<"b=w=====">>), + "one" = MimeDecodeToString(<<"b2=5l===">>), + "on" = MimeDecodeToString(<<"b=24====">>), + "o" = MimeDecodeToString(<<"b=w=====">>), %% Test misc white space and illegals with embedded padding - "one" = base64:mime_decode_to_string(<<" b~2=\r\n5()l===">>), - "on" = base64:mime_decode_to_string(<<"\tb =2\"¤4=¤= ==">>), - "o" = base64:mime_decode_to_string(<<"\nb=w=====">>), + "one" = MimeDecodeToString(<<" b~2=\r\n5()l===">>), + "on" = MimeDecodeToString(<<"\tb =2\"¤4=¤= ==">>), + "o" = MimeDecodeToString(<<"\nb=w=====">>), %% Two pads "Aladdin:open sesame" = - base64:mime_decode_to_string("QWxhZGRpbjpvc()GVuIHNlc2FtZQ=="), + MimeDecodeToString(<<"QWxhZGRpbjpvc()GVuIHNlc2FtZQ==">>), %% One pad to ignore, followed by more text - "Hello World!!" = base64:mime_decode_to_string(<<"SGVsb)(G8gV29ybGQ=h IQ= =">>), + "Hello World!!" = MimeDecodeToString(<<"SGVsb)(G8gV29ybGQ=h IQ= =">>), %% No pad "Aladdin:open sesam" = - base64:mime_decode_to_string("QWxhZGRpbjpvcG¤\")(VuIHNlc2Ft"), + MimeDecodeToString(<<"QWxhZGRpbjpvcG¤\")(VuIHNlc2Ft">>), %% Encoded base 64 strings may be divided by non base 64 chars. %% In this cases whitespaces. "0123456789!@#0^&*();:<>,. []{}" = - base64:mime_decode_to_string( + MimeDecodeToString( <<"MDEy MzQ1Njc4 \tOSFAIzBeJ \nio)(oKTs6 PD4sLi \r\nBbXXt9">>), + %% Zeroes + "012" = MimeDecodeToString(<<"\000M\000D\000E\000y=\000">>), + "o" = MimeDecodeToString(<<"bw==\000">>), + "o" = MimeDecodeToString(<<"bw=\000=">>), ok. %%------------------------------------------------------------------------- diff --git a/lib/stdlib/test/epp_SUITE.erl b/lib/stdlib/test/epp_SUITE.erl index 915f478dfa..9123bf2f28 100644 --- a/lib/stdlib/test/epp_SUITE.erl +++ b/lib/stdlib/test/epp_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1998-2017. All Rights Reserved. +%% Copyright Ericsson AB 1998-2018. 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. @@ -551,8 +551,8 @@ otp_8130(Config) when is_list(Config) -> "t() -> " " L = \"{ 34 , \\\"1\\\\x{AAA}\\\" , \\\"34\\\" , X . a , $\\\\x{AAA} }\", " " R = ?M({34,\"1\\x{aaa}\",\"34\",X.a,$\\x{aaa}})," - " Lt = erl_scan:string(L, 1, [unicode])," - " Rt = erl_scan:string(R, 1, [unicode])," + " Lt = erl_scan:string(L, 1)," + " Rt = erl_scan:string(R, 1)," " Lt = Rt, ok. ">>, ok}, diff --git a/lib/stdlib/test/erl_eval_SUITE.erl b/lib/stdlib/test/erl_eval_SUITE.erl index c3ef4eb051..8eb85cab8e 100644 --- a/lib/stdlib/test/erl_eval_SUITE.erl +++ b/lib/stdlib/test/erl_eval_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1998-2016. All Rights Reserved. +%% Copyright Ericsson AB 1998-2017. 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. @@ -41,6 +41,7 @@ otp_8133/1, otp_10622/1, otp_13228/1, + otp_14826/1, funs/1, try_catch/1, eval_expr_5/1, @@ -57,6 +58,7 @@ -export([count_down/2, count_down_fun/0, do_apply/2, local_func/3, local_func_value/2]). +-export([simple/0]). -ifdef(STANDALONE). -define(config(A,B),config(A,B)). @@ -83,7 +85,7 @@ all() -> pattern_expr, match_bin, guard_3, guard_4, guard_5, lc, simple_cases, unary_plus, apply_atom, otp_5269, otp_6539, otp_6543, otp_6787, otp_6977, otp_7550, - otp_8133, otp_10622, otp_13228, + otp_8133, otp_10622, otp_13228, otp_14826, funs, try_catch, eval_expr_5, zero_width, eep37, eep43]. @@ -988,6 +990,173 @@ otp_13228(_Config) -> EFH = {value, fun({io, fwrite}, [atom]) -> io_fwrite end}, {value, worked, []} = parse_and_run("foo(io:fwrite(atom)).", LFH, EFH). +%% OTP-14826: more accurate stacktrace. +otp_14826(_Config) -> + backtrace_check("fun(P) when is_pid(P) -> true end(a).", + function_clause, + [{erl_eval,'-inside-an-interpreted-fun-',[a],[]}, + {erl_eval,eval_fun,6}, + ?MODULE]), + backtrace_check("B.", + {unbound_var, 'B'}, + [{erl_eval,expr,2}, ?MODULE]), + backtrace_check("B.", + {unbound, 'B'}, + [{erl_eval,expr,5}, ?MODULE], + none, none), + backtrace_check("1/0.", + badarith, + [{erlang,'/',[1,0],[]}, + {erl_eval,do_apply,6}]), + backtrace_catch("catch 1/0.", + badarith, + [{erlang,'/',[1,0],[]}, + {erl_eval,do_apply,6}]), + check(fun() -> catch exit(foo) end, + "catch exit(foo).", + {'EXIT', foo}), + check(fun() -> catch throw(foo) end, + "catch throw(foo).", + foo), + backtrace_check("try 1/0 after foo end.", + badarith, + [{erlang,'/',[1,0],[]}, + {erl_eval,do_apply,6}]), + backtrace_catch("catch (try 1/0 after foo end).", + badarith, + [{erlang,'/',[1,0],[]}, + {erl_eval,do_apply,6}]), + backtrace_catch("try catch 1/0 after foo end.", + badarith, + [{erlang,'/',[1,0],[]}, + {erl_eval,do_apply,6}]), + backtrace_check("try a of b -> bar after foo end.", + {try_clause,a}, + [{erl_eval,try_clauses,8}]), + check(fun() -> X = try foo:bar() catch A:B:C -> {A,B} end, X end, + "try foo:bar() catch A:B:C -> {A,B} end.", + {error, undef}), + backtrace_check("C = 4, try foo:bar() catch A:B:C -> {A,B,C} end.", + stacktrace_bound, + [{erl_eval,check_stacktrace_vars,2}, + {erl_eval,try_clauses,8}], + none, none), + backtrace_catch("catch (try a of b -> bar after foo end).", + {try_clause,a}, + [{erl_eval,try_clauses,8}]), + backtrace_check("try 1/0 catch exit:a -> foo end.", + badarith, + [{erlang,'/',[1,0],[]}, + {erl_eval,do_apply,6}]), + Es = [{'try',1,[{call,1,{remote,1,{atom,1,foo},{atom,1,bar}},[]}], + [], + [{clause,1,[{tuple,1,[{var,1,'A'},{var,1,'B'},{atom,1,'C'}]}], + [],[{tuple,1,[{var,1,'A'},{var,1,'B'},{atom,1,'C'}]}]}],[]}], + try + erl_eval:exprs(Es, [], none, none), + ct:fail(stacktrace_variable) + catch + error:{illegal_stacktrace_variable,{atom,1,'C'}}:S -> + [{erl_eval,check_stacktrace_vars,2,_}, + {erl_eval,try_clauses,8,_}|_] = S + end, + backtrace_check("{1,1} = {A = 1, A = 2}.", + {badmatch, 1}, + [erl_eval, {lists,foldl,3}]), + backtrace_check("case a of a when foo:bar() -> x end.", + guard_expr, + [{erl_eval,guard0,4}], none, none), + backtrace_check("case a of foo() -> ok end.", + {illegal_pattern,{call,1,{atom,1,foo},[]}}, + [{erl_eval,match,4}], none, none), + backtrace_check("case a of b -> ok end.", + {case_clause,a}, + [{erl_eval,case_clauses,6}, ?MODULE]), + backtrace_check("if a =:= b -> ok end.", + if_clause, + [{erl_eval,if_clauses,5}, ?MODULE]), + backtrace_check("fun A(b) -> ok end(a).", + function_clause, + [{erl_eval,'-inside-an-interpreted-fun-',[a],[]}, + {erl_eval,eval_named_fun,8}, + ?MODULE]), + backtrace_check("[A || A <- a].", + {bad_generator, a}, + [{erl_eval,eval_generate,7}, {erl_eval, eval_lc, 6}]), + backtrace_check("<< <<A>> || <<A>> <= a>>.", + {bad_generator, a}, + [{erl_eval,eval_b_generate,7}, {erl_eval, eval_bc, 6}]), + backtrace_check("[A || A <- [1], begin a end].", + {bad_filter, a}, + [{erl_eval,eval_filter,6}, {erl_eval, eval_generate, 7}]), + fun() -> + {'EXIT', {{badarity, {_Fun, []}}, BT}} = + (catch parse_and_run("fun(A) -> A end().")), + check_backtrace([{erl_eval,do_apply,5}, ?MODULE], BT) + end(), + fun() -> + {'EXIT', {{badarity, {_Fun, []}}, BT}} = + (catch parse_and_run("fun F(A) -> A end().")), + check_backtrace([{erl_eval,do_apply,5}, ?MODULE], BT) + end(), + backtrace_check("foo().", + undef, + [{erl_eval,foo,0},{erl_eval,local_func,6}], + none, none), + backtrace_check("a orelse false.", + {badarg, a}, + [{erl_eval,expr,5}, ?MODULE]), + backtrace_check("a andalso false.", + {badarg, a}, + [{erl_eval,expr,5}, ?MODULE]), + backtrace_check("t = u.", + {badmatch, u}, + [{erl_eval,expr,5}, ?MODULE]), + backtrace_check("{math,sqrt}(2).", + {badfun, {math,sqrt}}, + [{erl_eval,expr,5}, ?MODULE]), + backtrace_check("erl_eval_SUITE:simple().", + simple, + [{?MODULE,simple1,0},{?MODULE,simple,0},erl_eval]), + Args = [{integer,1,I} || I <- lists:seq(1, 30)], + backtrace_check("fun(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18," + "19,20,21,22,23,24,25,26,27,28,29,30) -> a end.", + {argument_limit, + {'fun',1,[{clause,1,Args,[],[{atom,1,a}]}]}}, + [{erl_eval,expr,5}, ?MODULE]), + backtrace_check("fun F(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18," + "19,20,21,22,23,24,25,26,27,28,29,30) -> a end.", + {argument_limit, + {named_fun,1,'F',[{clause,1,Args,[],[{atom,1,a}]}]}}, + [{erl_eval,expr,5}, ?MODULE]), + backtrace_check("#r{}.", + {undef_record,r}, + [{erl_eval,expr,5}, ?MODULE], + none, none), + %% eval_bits + backtrace_check("<<100:8/bitstring>>.", + badarg, + [{eval_bits,eval_exp_field1,6}, + eval_bits,eval_bits,erl_eval]), + backtrace_check("<<100:8/foo>>.", + {undefined_bittype,foo}, + [{eval_bits,make_bit_type,3},eval_bits, + eval_bits,erl_eval], + none, none), + backtrace_check("B = <<\"foo\">>, <<B/binary-unit:7>>.", + badarg, + [{eval_bits,eval_exp_field1,6}, + eval_bits,eval_bits,erl_eval], + none, none), + ok. + +simple() -> + A = simple1(), + {A}. + +simple1() -> + erlang:error(simple). + %% Simple cases, just to cover some code. funs(Config) when is_list(Config) -> do_funs(none, none), @@ -1488,6 +1657,43 @@ error_check(String, Result, LFH, EFH) -> ct:fail({eval, Other, Result}) end. +backtrace_check(String, Result, Backtrace) -> + case catch parse_and_run(String) of + {'EXIT', {Result, BT}} -> + check_backtrace(Backtrace, BT); + Other -> + ct:fail({eval, Other, Result}) + end. + +backtrace_check(String, Result, Backtrace, LFH, EFH) -> + case catch parse_and_run(String, LFH, EFH) of + {'EXIT', {Result, BT}} -> + check_backtrace(Backtrace, BT); + Other -> + ct:fail({eval, Other, Result}) + end. + +backtrace_catch(String, Result, Backtrace) -> + case parse_and_run(String) of + {value, {'EXIT', {Result, BT}}, _Bindings} -> + check_backtrace(Backtrace, BT); + Other -> + ct:fail({eval, Other, Result}) + end. + +check_backtrace([B1|Backtrace], [B2|BT]) -> + case {B1, B2} of + {M, {M,_,_,_}} -> + ok; + {{M,F,A}, {M,F,A,_}} -> + ok; + {B, B} -> + ok + end, + check_backtrace(Backtrace, BT); +check_backtrace([], _) -> + ok. + eval_string(String) -> {value, Result, _} = parse_and_run(String), Result. @@ -1499,8 +1705,8 @@ parse_and_run(String) -> parse_and_run(String, LFH, EFH) -> {ok,Tokens,_} = erl_scan:string(String), - {ok, [Expr]} = erl_parse:parse_exprs(Tokens), - erl_eval:expr(Expr, [], LFH, EFH). + {ok, Exprs} = erl_parse:parse_exprs(Tokens), + erl_eval:exprs(Exprs, [], LFH, EFH). no_final_dot(S) -> case lists:reverse(S) of diff --git a/lib/stdlib/test/erl_lint_SUITE.erl b/lib/stdlib/test/erl_lint_SUITE.erl index b76bece07f..e40f5e9a5d 100644 --- a/lib/stdlib/test/erl_lint_SUITE.erl +++ b/lib/stdlib/test/erl_lint_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2017. All Rights Reserved. +%% Copyright Ericsson AB 1999-2018. 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. @@ -66,7 +66,8 @@ otp_11851/1,otp_11879/1,otp_13230/1, record_errors/1, otp_11879_cont/1, non_latin1_module/1, otp_14323/1, - get_stacktrace/1, otp_14285/1, otp_14378/1]). + get_stacktrace/1, stacktrace_syntax/1, + otp_14285/1, otp_14378/1]). suite() -> [{ct_hooks,[ts_install_cth]}, @@ -87,7 +88,7 @@ all() -> maps, maps_type, maps_parallel_match, otp_11851, otp_11879, otp_13230, record_errors, otp_11879_cont, non_latin1_module, otp_14323, - get_stacktrace, otp_14285, otp_14378]. + get_stacktrace, stacktrace_syntax, otp_14285, otp_14378]. groups() -> [{unused_vars_warn, [], @@ -3981,8 +3982,9 @@ non_latin1_module(Config) -> do_non_latin1_module(Mod) -> File = atom_to_list(Mod) ++ ".erl", - Forms = [{attribute,1,file,{File,1}}, - {attribute,1,module,Mod}, + L1 = erl_anno:new(1), + Forms = [{attribute,L1,file,{File,1}}, + {attribute,L1,module,Mod}, {eof,2}], error = compile:forms(Forms), {error,_,[]} = compile:forms(Forms, [return]), @@ -4129,6 +4131,40 @@ get_stacktrace(Config) -> run(Config, Ts), ok. +stacktrace_syntax(Config) -> + Ts = [{guard, + <<"t1() -> + try error(foo) + catch _:_:Stk when is_number(Stk) -> ok + end. + ">>, + [], + {errors,[{3,erl_lint,{stacktrace_guard,'Stk'}}],[]}}, + {bound, + <<"t1() -> + Stk = [], + try error(foo) + catch _:_:Stk -> ok + end. + ">>, + [], + {errors,[{4,erl_lint,{stacktrace_bound,'Stk'}}],[]}}, + {guard_and_bound, + <<"t1() -> + Stk = [], + try error(foo) + catch _:_:Stk when is_integer(Stk) -> ok + end. + ">>, + [], + {errors,[{4,erl_lint,{stacktrace_bound,'Stk'}}, + {4,erl_lint,{stacktrace_guard,'Stk'}}],[]}} + ], + + run(Config, Ts), + ok. + + %% Unicode atoms. otp_14285(Config) -> %% A small sample of all the errors and warnings in module erl_lint. diff --git a/lib/stdlib/test/erl_pp_SUITE.erl b/lib/stdlib/test/erl_pp_SUITE.erl index 808ba9b4c1..dda8d0a12e 100644 --- a/lib/stdlib/test/erl_pp_SUITE.erl +++ b/lib/stdlib/test/erl_pp_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2006-2017. All Rights Reserved. +%% Copyright Ericsson AB 2006-2018. 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. @@ -1262,7 +1262,7 @@ parse_forms(Chars) -> parse_forms2([], _Cont, _Line, Forms) -> lists:reverse(Forms); parse_forms2(String, Cont0, Line, Forms) -> - case erl_scan:tokens(Cont0, String, Line, [unicode]) of + case erl_scan:tokens(Cont0, String, Line) of {done, {ok, Tokens, EndLine}, Chars} -> {ok, Form} = erl_parse:parse_form(Tokens), parse_forms2(Chars, [], EndLine, [Form | Forms]); @@ -1303,7 +1303,7 @@ parse_and_pp_expr(String, Indent, Options) -> erl_pp:expr(parse_expr(StringDot), Indent, Options). parse_expr(Chars) -> - {ok, Tokens, _} = erl_scan:string(Chars, 1, [unicode]), + {ok, Tokens, _} = erl_scan:string(Chars, 1), {ok, [Expr]} = erl_parse:parse_exprs(Tokens), Expr. diff --git a/lib/stdlib/test/escript_SUITE_data/unicode1 b/lib/stdlib/test/escript_SUITE_data/unicode1 index 351bb785e5..8dc9d450b8 100755 --- a/lib/stdlib/test/escript_SUITE_data/unicode1 +++ b/lib/stdlib/test/escript_SUITE_data/unicode1 @@ -8,7 +8,7 @@ main(_) -> _D = erlang:system_flag(backtrace_depth, 0), A = <<"\x{aaa}"/utf8>>, S = lists:flatten(io_lib:format("~p/~p.", [A, A])), - {ok, Ts, _} = erl_scan:string(S, 1, [unicode]), + {ok, Ts, _} = erl_scan:string(S, 1), {ok, Es} = erl_parse:parse_exprs(Ts), B = erl_eval:new_bindings(), erl_eval:exprs(Es, B). diff --git a/lib/stdlib/test/escript_SUITE_data/unicode2 b/lib/stdlib/test/escript_SUITE_data/unicode2 index 495188f6f0..d0195b036c 100755 --- a/lib/stdlib/test/escript_SUITE_data/unicode2 +++ b/lib/stdlib/test/escript_SUITE_data/unicode2 @@ -8,7 +8,7 @@ main(_) -> _D = erlang:system_flag(backtrace_depth, 0), A = <<"\x{aa}">>, S = lists:flatten(io_lib:format("~p/~p.", [A, A])), - {ok, Ts, _} = erl_scan:string(S, 1, [unicode]), + {ok, Ts, _} = erl_scan:string(S, 1), {ok, Es} = erl_parse:parse_exprs(Ts), B = erl_eval:new_bindings(), erl_eval:exprs(Es, B). diff --git a/lib/stdlib/test/ets_SUITE.erl b/lib/stdlib/test/ets_SUITE.erl index 5a5e282998..07c8b60cbd 100644 --- a/lib/stdlib/test/ets_SUITE.erl +++ b/lib/stdlib/test/ets_SUITE.erl @@ -1682,7 +1682,7 @@ do_random_test() -> ets:delete(Set), verify_etsmem(EtsMem). -%% Ttest various variants of update_element. +%% Test various variants of update_element. update_element(Config) when is_list(Config) -> EtsMem = etsmem(), repeat_for_opts(fun update_element_opts/1), @@ -6369,7 +6369,7 @@ very_big_num(0, Result) -> Result. make_port() -> - open_port({spawn, "efile"}, [eof]). + hd(erlang:ports()). make_pid() -> spawn_link(fun sleeper/0). diff --git a/lib/stdlib/test/filelib_SUITE.erl b/lib/stdlib/test/filelib_SUITE.erl index 1236fe45f4..7403d52881 100644 --- a/lib/stdlib/test/filelib_SUITE.erl +++ b/lib/stdlib/test/filelib_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2005-2017. All Rights Reserved. +%% Copyright Ericsson AB 2005-2018. 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. @@ -26,13 +26,15 @@ wildcard_one/1,wildcard_two/1,wildcard_errors/1, fold_files/1,otp_5960/1,ensure_dir_eexist/1,ensure_dir_symlink/1, wildcard_symlink/1, is_file_symlink/1, file_props_symlink/1, - find_source/1]). + find_source/1, find_source_subdir/1]). -import(lists, [foreach/2]). -include_lib("common_test/include/ct.hrl"). -include_lib("kernel/include/file.hrl"). +-define(PRIM_FILE, prim_file). + init_per_testcase(_Case, Config) -> Config. @@ -47,7 +49,7 @@ all() -> [wildcard_one, wildcard_two, wildcard_errors, fold_files, otp_5960, ensure_dir_eexist, ensure_dir_symlink, wildcard_symlink, is_file_symlink, file_props_symlink, - find_source]. + find_source, find_source_subdir]. groups() -> []. @@ -446,10 +448,10 @@ wildcard_symlink(Config) when is_list(Config) -> erl_prim_loader)), ["sub","symlink"] = basenames(Dir, filelib:wildcard(filename:join(Dir, "*"), - prim_file)), + ?PRIM_FILE)), ["symlink"] = basenames(Dir, filelib:wildcard(filename:join(Dir, "symlink"), - prim_file)), + ?PRIM_FILE)), ok = file:delete(AFile), %% The symlink should still be visible even when its target %% has been deleted. @@ -465,10 +467,10 @@ wildcard_symlink(Config) when is_list(Config) -> erl_prim_loader)), ["sub","symlink"] = basenames(Dir, filelib:wildcard(filename:join(Dir, "*"), - prim_file)), + ?PRIM_FILE)), ["symlink"] = basenames(Dir, filelib:wildcard(filename:join(Dir, "symlink"), - prim_file)), + ?PRIM_FILE)), ok end. @@ -497,17 +499,17 @@ is_file_symlink(Config) -> ok -> true = filelib:is_dir(DirAlias), true = filelib:is_dir(DirAlias, erl_prim_loader), - true = filelib:is_dir(DirAlias, prim_file), + true = filelib:is_dir(DirAlias, ?PRIM_FILE), true = filelib:is_file(DirAlias), true = filelib:is_file(DirAlias, erl_prim_loader), - true = filelib:is_file(DirAlias, prim_file), + true = filelib:is_file(DirAlias, ?PRIM_FILE), ok = file:make_symlink(AFile,FileAlias), true = filelib:is_file(FileAlias), true = filelib:is_file(FileAlias, erl_prim_loader), - true = filelib:is_file(FileAlias, prim_file), + true = filelib:is_file(FileAlias, ?PRIM_FILE), true = filelib:is_regular(FileAlias), true = filelib:is_regular(FileAlias, erl_prim_loader), - true = filelib:is_regular(FileAlias, prim_file), + true = filelib:is_regular(FileAlias, ?PRIM_FILE), ok end. @@ -528,11 +530,11 @@ file_props_symlink(Config) -> {_,_} = LastMod = filelib:last_modified(AFile), LastMod = filelib:last_modified(Alias), LastMod = filelib:last_modified(Alias, erl_prim_loader), - LastMod = filelib:last_modified(Alias, prim_file), + LastMod = filelib:last_modified(Alias, ?PRIM_FILE), FileSize = filelib:file_size(AFile), FileSize = filelib:file_size(Alias), FileSize = filelib:file_size(Alias, erl_prim_loader), - FileSize = filelib:file_size(Alias, prim_file) + FileSize = filelib:file_size(Alias, ?PRIM_FILE) end. find_source(Config) when is_list(Config) -> @@ -565,16 +567,18 @@ find_source(Config) when is_list(Config) -> [{".erl",".yrl",[{"",""}]}]), {ok, ParserErl} = filelib:find_source(code:which(core_parse)), + ParserErlName = filename:basename(ParserErl), + ParserErlDir = filename:dirname(ParserErl), {ok, ParserYrl} = filelib:find_source(ParserErl), "lry." ++ _ = lists:reverse(ParserYrl), - {ok, ParserYrl} = filelib:find_source(ParserErl, + {ok, ParserYrl} = filelib:find_source(ParserErlName, ParserErlDir, [{".beam",".erl",[{"ebin","src"}]}, {".erl",".yrl",[{"",""}]}]), %% find_source automatically checks the local directory regardless of rules {ok, ParserYrl} = filelib:find_source(ParserErl), - {ok, ParserYrl} = filelib:find_source(ParserErl, - [{".beam",".erl",[{"ebin","src"}]}]), + {ok, ParserYrl} = filelib:find_source(ParserErlName, ParserErlDir, + [{".erl",".yrl",[{"ebin","src"}]}]), %% find_file does not check the local directory unless in the rules ParserYrlName = filename:basename(ParserYrl), @@ -588,3 +592,24 @@ find_source(Config) when is_list(Config) -> {ok, ParserYrl} = filelib:find_file(ParserYrlName, ParserYrlDir), {ok, ParserYrl} = filelib:find_file(ParserYrlName, ParserYrlDir, []), ok. + +find_source_subdir(Config) when is_list(Config) -> + BeamFile = code:which(inets), % Located in lib/inets/src/inets_app/ + BeamName = filename:basename(BeamFile), + BeamDir = filename:dirname(BeamFile), + SrcName = filename:basename(BeamFile, ".beam") ++ ".erl", + + {ok, SrcFile} = filelib:find_source(BeamName, BeamDir), + SrcName = filename:basename(SrcFile), + + {error, not_found} = + filelib:find_source(BeamName, BeamDir, + [{".beam",".erl",[{"ebin","src"}]}]), + {ok, SrcFile} = + filelib:find_source(BeamName, BeamDir, + [{".beam",".erl", + [{"ebin",filename:join("src", "*")}]}]), + + {ok, SrcFile} = filelib:find_file(SrcName, BeamDir), + + ok. diff --git a/lib/stdlib/test/gen_fsm_SUITE.erl b/lib/stdlib/test/gen_fsm_SUITE.erl index 86cf58566b..41ee3246f5 100644 --- a/lib/stdlib/test/gen_fsm_SUITE.erl +++ b/lib/stdlib/test/gen_fsm_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -389,7 +389,7 @@ stop10(_Config) -> Dir = filename:dirname(code:which(?MODULE)), rpc:call(Node,code,add_path,[Dir]), {ok, Pid} = rpc:call(Node,gen_fsm,start,[{global,to_stop},?MODULE,[],[]]), - global:sync(), + ok = global:sync(), ok = gen_fsm:stop({global,to_stop}), false = rpc:call(Node,erlang,is_process_alive,[Pid]), {'EXIT',noproc} = (catch gen_fsm:stop({global,to_stop})), @@ -1005,7 +1005,7 @@ undef_in_terminate(Config) when is_list(Config) -> State = {undef_in_terminate, {?MODULE, terminate}}, {ok, FSM} = gen_fsm:start(?MODULE, {state_data, State}, []), try - gen_fsm:stop(FSM), + ok = gen_fsm:stop(FSM), ct:fail(failed) catch exit:{undef, [{?MODULE, terminate, _, _}|_]} -> @@ -1201,7 +1201,7 @@ timeout({timeout,Ref,{timeout,Time}}, {From,Ref}) -> Cref = gen_fsm:start_timer(Time, cancel), Time4 = Time*4, receive after Time4 -> ok end, - gen_fsm:cancel_timer(Cref), + _= gen_fsm:cancel_timer(Cref), {next_state, timeout, {From,Ref2}}; timeout({timeout,Ref2,ok},{From,Ref2}) -> gen_fsm:reply(From, ok), diff --git a/lib/stdlib/test/gen_server_SUITE.erl b/lib/stdlib/test/gen_server_SUITE.erl index 2bc220fef2..e29195e895 100644 --- a/lib/stdlib/test/gen_server_SUITE.erl +++ b/lib/stdlib/test/gen_server_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -347,7 +347,7 @@ stop10(_Config) -> Dir = filename:dirname(code:which(?MODULE)), rpc:call(Node,code,add_path,[Dir]), {ok, Pid} = rpc:call(Node,gen_server,start,[{global,to_stop},?MODULE,[],[]]), - global:sync(), + ok = global:sync(), ok = gen_server:stop({global,to_stop}), false = rpc:call(Node,erlang,is_process_alive,[Pid]), {'EXIT',noproc} = (catch gen_server:stop({global,to_stop})), @@ -509,7 +509,7 @@ start_node(Name) -> %% After starting a slave, it takes a little while until global knows %% about it, even if nodes() includes it, so we make sure that global %% knows about it before registering something on all nodes. - global:sync(), + ok = global:sync(), N. call_remote1(Config) when is_list(Config) -> @@ -647,7 +647,7 @@ cast_fast(Config) when is_list(Config) -> cast_fast_messup() -> %% Register a false node: hopp@hostname unregister(erl_epmd), - erl_epmd:start_link(), + {ok, _} = erl_epmd:start_link(), {ok,S} = gen_tcp:listen(0, []), {ok,P} = inet:port(S), {ok,_Creation} = erl_epmd:register_node(hopp, P), @@ -1351,7 +1351,7 @@ do_call_with_huge_message_queue() -> {Time,ok} = tc(fun() -> calls(10000, Pid) end), - [self() ! {msg,N} || N <- lists:seq(1, 500000)], + _ = [self() ! {msg,N} || N <- lists:seq(1, 500000)], erlang:garbage_collect(), {NewTime,ok} = tc(fun() -> calls(10000, Pid) end), io:format("Time for empty message queue: ~p", [Time]), @@ -1476,7 +1476,7 @@ undef_in_terminate(Config) when is_list(Config) -> State = {undef_in_terminate, {oc_server, terminate}}, {ok, Server} = gen_server:start(?MODULE, {state, State}, []), try - gen_server:stop(Server), + ok = gen_server:stop(Server), ct:fail(failed) catch exit:{undef, [{oc_server, terminate, [], _}|_]} -> @@ -1674,7 +1674,7 @@ handle_cast({From,delayed_cast,T}, _State) -> handle_cast(hibernate_now, _State) -> {noreply, [], hibernate}; handle_cast(hibernate_later, _State) -> - timer:send_after(1000,self(),hibernate_now), + {ok, _} = timer:send_after(1000,self(),hibernate_now), {noreply, []}; handle_cast({call_undef_fun, Mod, Fun}, State) -> Mod:Fun(), diff --git a/lib/stdlib/test/gen_statem_SUITE.erl b/lib/stdlib/test/gen_statem_SUITE.erl index 5b9daecfd3..c747db475a 100644 --- a/lib/stdlib/test/gen_statem_SUITE.erl +++ b/lib/stdlib/test/gen_statem_SUITE.erl @@ -21,7 +21,7 @@ -include_lib("common_test/include/ct.hrl"). --compile(export_all). +-compile([export_all, nowarn_export_all]). -behaviour(gen_statem). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/lib/stdlib/test/io_SUITE.erl b/lib/stdlib/test/io_SUITE.erl index e2c73371cd..45363c0592 100644 --- a/lib/stdlib/test/io_SUITE.erl +++ b/lib/stdlib/test/io_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2017. All Rights Reserved. +%% Copyright Ericsson AB 1999-2018. 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. @@ -714,7 +714,7 @@ p(Term, D) -> rp(Term, 1, 80, D). p(Term, Col, Ll, D) -> - rp(Term, Col, Ll, D, no_fun). + rp(Term, Col, Ll, D, none). rp(Term, Col, Ll, D) -> rp(Term, Col, Ll, D, fun rfd/2). @@ -724,6 +724,8 @@ rp(Term, Col, Ll, D) -> rp(Term, Col, Ll, D, RF) -> rp(Term, Col, Ll, D, ?MAXCS, RF). +rp(Term, Col, Ll, D, M, none) -> + rp(Term, Col, Ll, D, M, fun(_, _) -> no end); rp(Term, Col, Ll, D, M, RF) -> %% io:format("~n~n*** Col = ~p Ll = ~p D = ~p~n~p~n-->~n", %% [Col, Ll, D, Term]), @@ -2138,8 +2140,8 @@ otp_14175(_Config) -> "#{}" = p(#{}, 1), "#{...}" = p(#{a => 1}, 1), "#{#{} => a}" = p(#{#{} => a}, 2), - "#{a => 1,...}" = p(#{a => 1, b => 2}, 2), - "#{a => 1,b => 2}" = p(#{a => 1, b => 2}, -1), + mt("#{a => 1,...}", p(#{a => 1, b => 2}, 2)), + mt("#{a => 1,b => 2}", p(#{a => 1, b => 2}, -1)), M = #{kaaaaaaaaaaaaaaaaaaa => v1,kbbbbbbbbbbbbbbbbbbb => v2, kccccccccccccccccccc => v3,kddddddddddddddddddd => v4, diff --git a/lib/stdlib/test/maps_SUITE.erl b/lib/stdlib/test/maps_SUITE.erl index 42e669a799..a75751b31d 100644 --- a/lib/stdlib/test/maps_SUITE.erl +++ b/lib/stdlib/test/maps_SUITE.erl @@ -30,6 +30,7 @@ -export([t_update_with_3/1, t_update_with_4/1, t_get_3/1, t_filter_2/1, t_fold_3/1,t_map_2/1,t_size_1/1, + t_iterator_1/1, t_with_2/1,t_without_2/1]). %%-define(badmap(V,F,Args), {'EXIT', {{badmap,V}, [{maps,F,Args,_}|_]}}). @@ -47,6 +48,7 @@ all() -> [t_update_with_3,t_update_with_4, t_get_3,t_filter_2, t_fold_3,t_map_2,t_size_1, + t_iterator_1, t_with_2,t_without_2]. t_update_with_3(Config) when is_list(Config) -> @@ -127,6 +129,8 @@ t_filter_2(Config) when is_list(Config) -> Pred2 = fun(K,V) -> is_list(K) andalso (V rem 2) =:= 0 end, #{a := 2,c := 4} = maps:filter(Pred1,M), #{"b" := 2,"c" := 4} = maps:filter(Pred2,M), + #{a := 2,c := 4} = maps:filter(Pred1,maps:iterator(M)), + #{"b" := 2,"c" := 4} = maps:filter(Pred2,maps:iterator(M)), %% error case ?badmap(a,filter,[_,a]) = (catch maps:filter(fun(_,_) -> ok end,id(a))), ?badarg(filter,[<<>>,#{}]) = (catch maps:filter(id(<<>>),#{})), @@ -139,6 +143,8 @@ t_fold_3(Config) when is_list(Config) -> Tot0 = lists:sum(Vs), Tot1 = maps:fold(fun({k,_},V,A) -> A + V end, 0, M0), true = Tot0 =:= Tot1, + Tot2 = maps:fold(fun({k,_},V,A) -> A + V end, 0, maps:iterator(M0)), + true = Tot0 =:= Tot2, %% error case ?badmap(a,fold,[_,0,a]) = (catch maps:fold(fun(_,_,_) -> ok end,0,id(a))), @@ -151,12 +157,48 @@ t_map_2(Config) when is_list(Config) -> #{ {k,1} := 1, {k,200} := 200} = M0, M1 = maps:map(fun({k,_},V) -> V + 42 end, M0), #{ {k,1} := 43, {k,200} := 242} = M1, + M2 = maps:map(fun({k,_},V) -> V + 42 end, maps:iterator(M0)), + #{ {k,1} := 43, {k,200} := 242} = M2, %% error case ?badmap(a,map,[_,a]) = (catch maps:map(fun(_,_) -> ok end, id(a))), ?badarg(map,[<<>>,#{}]) = (catch maps:map(id(<<>>),#{})), ok. +t_iterator_1(Config) when is_list(Config) -> + + %% Small map test + M0 = #{ a => 1, b => 2 }, + I0 = maps:iterator(M0), + {K1,V1,I1} = maps:next(I0), + {K2,V2,I2} = maps:next(I1), + none = maps:next(I2), + + KVList = lists:sort([{K1,V1},{K2,V2}]), + KVList = lists:sort(maps:to_list(M0)), + + %% Large map test + + Vs2 = lists:seq(1,200), + M2 = maps:from_list([{{k,I},I}||I<-Vs2]), + KVList2 = lists:sort(iter_kv(maps:iterator(M2))), + KVList2 = lists:sort(maps:to_list(M2)), + + %% Larger map test + + Vs3 = lists:seq(1,10000), + M3 = maps:from_list([{{k,I},I}||I<-Vs3]), + KVList3 = lists:sort(iter_kv(maps:iterator(M3))), + KVList3 = lists:sort(maps:to_list(M3)), + ok. + +iter_kv(I) -> + case maps:next(I) of + none -> + []; + {K,V,NI} -> + [{K,V} | iter_kv(NI)] + end. t_size_1(Config) when is_list(Config) -> 0 = maps:size(#{}), diff --git a/lib/stdlib/test/property_test/README b/lib/stdlib/test/property_test/README new file mode 100644 index 0000000000..57602bf719 --- /dev/null +++ b/lib/stdlib/test/property_test/README @@ -0,0 +1,12 @@ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% %%% +%%% WARNING %%% +%%% %%% +%%% This is experimental code which may be changed or removed %%% +%%% anytime without any warning. %%% +%%% %%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +The test in this directory are written assuming that the user has a QuickCheck license. They are to be run manually. Some may be possible to be run with other tools, e.g. PropEr. + diff --git a/lib/stdlib/test/property_test/uri_string_recompose.erl b/lib/stdlib/test/property_test/uri_string_recompose.erl new file mode 100644 index 0000000000..e51a671172 --- /dev/null +++ b/lib/stdlib/test/property_test/uri_string_recompose.erl @@ -0,0 +1,361 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2008-2017. 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(uri_string_recompose). + +-compile(export_all). + +-proptest(eqc). +-proptest([triq,proper]). + +-ifndef(EQC). +-ifndef(PROPER). +-ifndef(TRIQ). +-define(EQC,true). +-endif. +-endif. +-endif. + +-ifdef(EQC). +-include_lib("eqc/include/eqc.hrl"). +-define(MOD_eqc,eqc). + +-else. +-ifdef(PROPER). +-include_lib("proper/include/proper.hrl"). +-define(MOD_eqc,proper). + +-else. +-ifdef(TRIQ). +-define(MOD_eqc,triq). +-include_lib("triq/include/triq.hrl"). + +-endif. +-endif. +-endif. + + +-define(STRING_REST(MatchStr, Rest), <<MatchStr/utf8, Rest/binary>>). + +-define(SCHEME, {scheme, scheme()}). +-define(USER, {userinfo, unicode()}). +-define(HOST, {host, host_map()}). +-define(PORT, {port, port()}). +-define(PATH_ABE, {path, path_abempty_map()}). +-define(PATH_ABS, {path, path_absolute_map()}). +-define(PATH_NOS, {path, path_noscheme_map()}). +-define(PATH_ROO, {path, path_rootless_map()}). +-define(PATH_EMP, {path, path_empty_map()}). +-define(QUERY, {query, query_map()}). +-define(FRAGMENT, {fragment, fragment_map()}). + + +%%%======================================================================== +%%% Properties +%%%======================================================================== + +prop_recompose() -> + ?FORALL(Map, map(), + Map =:= uri_string:parse(uri_string:recompose(Map)) + ). + +%% Stats +prop_map_key_length_collect() -> + ?FORALL(List, map(), + collect(length(maps:keys(List)), true)). + +prop_map_collect() -> + ?FORALL(List, map(), + collect(lists:sort(maps:keys(List)), true)). + +prop_scheme_collect() -> + ?FORALL(List, scheme(), + collect(length(List), true)). + + +%%%======================================================================== +%%% Generators +%%%======================================================================== + +map() -> + ?LET(Gen, comp_proplist(), proplist_to_map(Gen)). + +comp_proplist() -> + frequency([ + {2, [?SCHEME,?PATH_ABS]}, + {2, [?SCHEME,?PATH_ROO]}, + {2, [?SCHEME,?PATH_EMP]}, + {2, [?SCHEME,?HOST,?PATH_ABE]}, + {2, [?SCHEME,?USER,?HOST,?PATH_ABE]}, + {2, [?SCHEME,?HOST,?PORT,?PATH_ABE]}, + {2, [?SCHEME,?USER,?HOST,?PORT,?PATH_ABE]}, + + {2, [?PATH_ABS]}, + {2, [?PATH_NOS]}, + {2, [?PATH_EMP]}, + {2, [?HOST,?PATH_ABE]}, + {2, [?USER,?HOST,?PATH_ABE]}, + {2, [?HOST,?PORT,?PATH_ABE]}, + {2, [?USER,?HOST,?PORT,?PATH_ABE]}, + + + {2, [?SCHEME,?PATH_ABS,?QUERY]}, + {2, [?SCHEME,?PATH_ROO,?QUERY]}, + {2, [?SCHEME,?PATH_EMP,?QUERY]}, + {2, [?SCHEME,?HOST,?PATH_ABE,?QUERY]}, + {2, [?SCHEME,?USER,?HOST,?PATH_ABE,?QUERY]}, + {2, [?SCHEME,?HOST,?PORT,?PATH_ABE,?QUERY]}, + {2, [?SCHEME,?USER,?HOST,?PORT,?PATH_ABE,?QUERY]}, + + {2, [?PATH_ABS,?QUERY]}, + {2, [?PATH_NOS,?QUERY]}, + {2, [?PATH_EMP,?QUERY]}, + {2, [?HOST,?PATH_ABE,?QUERY]}, + {2, [?USER,?HOST,?PATH_ABE,?QUERY]}, + {2, [?HOST,?PORT,?PATH_ABE,?QUERY]}, + {2, [?USER,?HOST,?PORT,?PATH_ABE,?QUERY]}, + + + {2, [?SCHEME,?PATH_ABS,?FRAGMENT]}, + {2, [?SCHEME,?PATH_ROO,?FRAGMENT]}, + {2, [?SCHEME,?PATH_EMP,?FRAGMENT]}, + {2, [?SCHEME,?HOST,?PATH_ABE,?FRAGMENT]}, + {2, [?SCHEME,?USER,?HOST,?PATH_ABE,?FRAGMENT]}, + {2, [?SCHEME,?HOST,?PORT,?PATH_ABE,?FRAGMENT]}, + {2, [?SCHEME,?USER,?HOST,?PORT,?PATH_ABE,?FRAGMENT]}, + + {2, [?PATH_ABS,?FRAGMENT]}, + {2, [?PATH_NOS,?FRAGMENT]}, + {2, [?PATH_EMP,?FRAGMENT]}, + {2, [?HOST,?PATH_ABE,?FRAGMENT]}, + {2, [?USER,?HOST,?PATH_ABE,?FRAGMENT]}, + {2, [?HOST,?PORT,?PATH_ABE,?FRAGMENT]}, + {2, [?USER,?HOST,?PORT,?PATH_ABE,?FRAGMENT]}, + + + {2, [?SCHEME,?PATH_ABS,?QUERY,?FRAGMENT]}, + {2, [?SCHEME,?PATH_ROO,?QUERY,?FRAGMENT]}, + {2, [?SCHEME,?PATH_EMP,?QUERY,?FRAGMENT]}, + {2, [?SCHEME,?HOST,?PATH_ABE,?QUERY,?FRAGMENT]}, + {2, [?SCHEME,?USER,?HOST,?PATH_ABE,?QUERY,?FRAGMENT]}, + {2, [?SCHEME,?HOST,?PORT,?PATH_ABE,?QUERY,?FRAGMENT]}, + {2, [?SCHEME,?USER,?HOST,?PORT,?PATH_ABE,?QUERY,?FRAGMENT]}, + + {2, [?PATH_ABS,?QUERY,?FRAGMENT]}, + {2, [?PATH_NOS,?QUERY,?FRAGMENT]}, + {2, [?PATH_EMP,?QUERY,?FRAGMENT]}, + {2, [?HOST,?PATH_ABE,?QUERY,?FRAGMENT]}, + {2, [?USER,?HOST,?PATH_ABE,?QUERY,?FRAGMENT]}, + {2, [?HOST,?PORT,?PATH_ABE,?QUERY,?FRAGMENT]}, + {2, [?USER,?HOST,?PORT,?PATH_ABE,?QUERY,?FRAGMENT]} + ]). + + +%%------------------------------------------------------------------------- +%% Path +%%------------------------------------------------------------------------- +path_abempty_map() -> + frequency([{90, path_abe_map()}, + {10, path_empty_map()}]). + +path_abe_map() -> + ?SIZED(Length, path_abe_map(Length, [])). +%% +path_abe_map(0, Segments) -> + ?LET(Gen, Segments, lists:append(Gen)); +path_abe_map(N, Segments) -> + path_abe_map(N-1, [slash(),segment()|Segments]). + + +path_absolute_map() -> + ?SIZED(Length, path_absolute_map(Length, [])). +%% +path_absolute_map(0, Segments) -> + ?LET(Gen, [slash(),segment_nz()|Segments], lists:append(Gen)); +path_absolute_map(N, Segments) -> + path_absolute_map(N-1, [slash(),segment()|Segments]). + + +path_noscheme_map() -> + ?SIZED(Length, path_noscheme_map(Length, [])). +%% +path_noscheme_map(0, Segments) -> + ?LET(Gen, [segment_nz_nc()|Segments], lists:append(Gen)); +path_noscheme_map(N, Segments) -> + path_noscheme_map(N-1, [slash(),segment()|Segments]). + +path_rootless_map() -> + ?SIZED(Length, path_rootless_map(Length, [])). +%% +path_rootless_map(0, Segments) -> + ?LET(Gen, [segment_nz()|Segments], lists:append(Gen)); +path_rootless_map(N, Segments) -> + path_rootless_map(N-1, [slash(),segment()|Segments]). + + +segment_nz() -> + non_empty(segment()). + +segment_nz_nc() -> + non_empty(list(frequency([{30, unreserved()}, + {10, sub_delims()}, + {10, unicode_char()}, + {5, oneof([$@])} + ]))). + + +segment() -> + list(frequency([{30, unreserved()}, + {10, sub_delims()}, + {10, unicode_char()}, + {5, oneof([$:, $@])} + ])). + +slash() -> + "/". + +path_empty_map() -> + "". + + +%%------------------------------------------------------------------------- +%% Path +%%------------------------------------------------------------------------- +host_map() -> + frequency([{30, reg_name()}, + {30, ip_address()} + ]). + + +reg_name() -> + list(frequency([{30, alpha()}, + {10, sub_delims()}, + {10, unicode_char()} + ])). + +ip_address() -> + oneof(["127.0.0.1", "::127.0.0.1", + "2001:0db8:0000:0000:0000:0000:1428:07ab", + "2001:0db8:0000:0000:0000::1428:07ab", + "2001:0db8:0:0:0:0:1428:07ab", + "2001:0db8:0::0:1428:07ab"]). + +%% Generating only reg-names +host_uri() -> + non_empty(list(frequency([{30, unreserved()}, + {10, sub_delims()}, + {10, pct_encoded()} + ]))). + +%%------------------------------------------------------------------------- +%% Port, Query, Fragment +%%------------------------------------------------------------------------- +port() -> + frequency([{10, undefined}, + {10, range(1,65535)} + ]). + +query_map() -> + unicode(). + + +query_uri() -> + [$?| non_empty(list(frequency([{20, pchar()}, + {5, oneof([$/, $?])} % punctuation + ])))]. + +fragment_map() -> + unicode(). + +fragment_uri() -> + [$?| non_empty(list(frequency([{20, pchar()}, + {5, oneof([$/, $?])} % punctuation + ])))]. + + +%%------------------------------------------------------------------------- +%% Scheme +%%------------------------------------------------------------------------- +scheme() -> + ?SIZED(Length, scheme_start(Length, [])). +%% +scheme_start(0, L) -> + ?LET(Gen, L, lists:reverse(Gen)); +scheme_start(N, L) -> + scheme(N-1,[alpha()|L]). + +scheme(0, L) -> + ?LET(Gen, L, lists:reverse(Gen)); +scheme(N, L) -> + scheme(N-1, [scheme_char()|L]). + + +%%------------------------------------------------------------------------- +%% Misc +%%------------------------------------------------------------------------- +unicode() -> + list(frequency([{20, alpha()}, % alpha + {10, digit()}, % digit + {10, unicode_char()} % unicode + ])). + +scheme_char() -> + frequency([{20, alpha()}, % alpha + {20, digit()}, % digit + {5, oneof([$+, $-, $.])} % punctuation + ]). + +sub_delims() -> + oneof([$!, $$, $&, $', $(, $), + $*, $+, $,,$;, $=]). + +pchar() -> + frequency([{20, unreserved()}, + {5, pct_encoded()}, + {5, sub_delims()}, + {1, oneof([$:, $@])} % punctuation + ]). + +unreserved() -> + frequency([{20, alpha()}, + {5, digit()}, + {1, oneof([$-, $., $_, $~])} % punctuation + ]). + +unicode_char() -> + range(913, 1023). + +alpha() -> + frequency([{20, range($a, $z)}, % letters + {20, range($A, $Z)}]). % letters + +digit() -> + range($0, $9). % numbers + +pct_encoded() -> + oneof(["%C3%A4", "%C3%A5", "%C3%B6"]). + + +%%%======================================================================== +%%% Helpers +%%%======================================================================== +proplist_to_map(L) -> + lists:foldl(fun({K,V},M) -> M#{K => V}; + (_,M) -> M + end, #{}, L). diff --git a/lib/stdlib/test/qlc_SUITE.erl b/lib/stdlib/test/qlc_SUITE.erl index 5e9e03e410..8f8a0f6e73 100644 --- a/lib/stdlib/test/qlc_SUITE.erl +++ b/lib/stdlib/test/qlc_SUITE.erl @@ -1695,28 +1695,7 @@ sort(Config) when is_list(Config) -> [true || I <- lists:seq(1, 50000), not ets:insert(E, {I, I})], H = qlc:q([{X,Y} || X <- [a,b], Y <- qlc:sort(ets:table(E))]), 100000 = length(qlc:e(H)), - ets:delete(E)">>, - - begin - TmpDir = ?privdir, - [<<"TE = process_flag(trap_exit, true), - E = ets:new(foo, []), - [true || I <- lists:seq(1, 50000), not ets:insert(E, {I, I})], - Ports = erlang:ports(), - H = qlc:q([{X,Y} || X <- [a,b], - begin - [P] = erlang:ports() -- Ports, - exit(P, port_exit), - true - end, - Y <- qlc:sort(ets:table(E), - [{tmpdir,\"">>, - TmpDir, <<"\"}])]), - {error, qlc, {file_error, _, _}} = (catch qlc:e(H)), - receive {'EXIT', _, port_exit} -> ok end, - ets:delete(E), - process_flag(trap_exit, TE)">>] - end + ets:delete(E)">> ], run(Config, Ts), @@ -7871,7 +7850,7 @@ run_test(Config, Extra, {cres, Body, Opts, ExpectedCompileReturn}) -> {module, _} = code:load_abs(AbsFile, Mod), Ms0 = erlang:process_info(self(),messages), - Before = {{get(), lists:sort(ets:all()), Ms0}, pps()}, + Before = {{lget(), lists:sort(ets:all()), Ms0}, pps()}, %% Prepare the check that the qlc module does not call qlc_pt. _ = [unload_pt() || {file, Name} <- [code:is_loaded(qlc_pt)], @@ -7903,7 +7882,7 @@ run_test(Config, Extra, Body) -> wait_for_expected(R, {Strict0,PPS0}=Before, SourceFile, Wait) -> Ms = erlang:process_info(self(),messages), - After = {_,PPS1} = {{get(), lists:sort(ets:all()), Ms}, pps()}, + After = {_,PPS1} = {{lget(), lists:sort(ets:all()), Ms}, pps()}, case {R, After} of {ok, Before} -> ok; @@ -7931,6 +7910,18 @@ wait_for_expected(R, {Strict0,PPS0}=Before, SourceFile, Wait) -> expected({ok,Before}, {R,After}, SourceFile) end. +%% The qlc modules uses the process dictionary for storing names of files. +lget() -> + lists:sort([T || {K, _} = T <- get(), is_qlc_key(K)]). + +%% Copied from the qlc module. +-define(LCACHE_FILE(Ref), {Ref, '$_qlc_cache_tmpfiles_'}). +-define(MERGE_JOIN_FILE, '$_qlc_merge_join_tmpfiles_'). + +is_qlc_key(?LCACHE_FILE(_)) -> true; +is_qlc_key(?MERGE_JOIN_FILE) -> true; +is_qlc_key(_) -> false. + unload_pt() -> erlang:garbage_collect(), % get rid of references to qlc_pt... _ = code:purge(qlc_pt), diff --git a/lib/stdlib/test/rand_SUITE.erl b/lib/stdlib/test/rand_SUITE.erl index ef4f9faad9..3d3241b33d 100644 --- a/lib/stdlib/test/rand_SUITE.erl +++ b/lib/stdlib/test/rand_SUITE.erl @@ -29,6 +29,9 @@ basic_stats_uniform_1/1, basic_stats_uniform_2/1, basic_stats_standard_normal/1, basic_stats_normal/1, + stats_standard_normal_box_muller/1, + stats_standard_normal_box_muller_2/1, + stats_standard_normal/1, uniform_real_conv/1, plugin/1, measure/1, reference_jump_state/1, reference_jump_procdict/1]). @@ -57,7 +60,10 @@ all() -> groups() -> [{basic_stats, [parallel], [basic_stats_uniform_1, basic_stats_uniform_2, - basic_stats_standard_normal]}, + basic_stats_standard_normal, + stats_standard_normal_box_muller, + stats_standard_normal_box_muller_2, + stats_standard_normal]}, {reference_jump, [parallel], [reference_jump_state, reference_jump_procdict]}]. @@ -410,6 +416,206 @@ normal_s(Mean, Variance, State0) when Mean == 0, Variance == 1 -> normal_s(Mean, Variance, State0) -> rand:normal_s(Mean, Variance, State0). + + +-dialyzer({no_improper_lists, stats_standard_normal_box_muller/1}). +stats_standard_normal_box_muller(Config) when is_list(Config) -> + try math:erfc(1.0) of + _ -> + TwoPi = 2.0 * math:pi(), + NormalS = + fun + ([S0]) -> + {U1, S1} = rand:uniform_real_s(S0), + R = math:sqrt(-2.0 * math:log(U1)), + {U2, S2} = rand:uniform_s(S1), + T = TwoPi * U2, + Z0 = R * math:cos(T), + Z1 = R * math:sin(T), + {Z0, [S2|Z1]}; + ([S|Z]) -> + {Z, [S]} + end, + State = [rand:seed(exrop)], + stats_standard_normal(NormalS, State) + catch error:_ -> + {skip, "math:erfc/1 not supported"} + end. + +-dialyzer({no_improper_lists, stats_standard_normal_box_muller_2/1}). +stats_standard_normal_box_muller_2(Config) when is_list(Config) -> + try math:erfc(1.0) of + _ -> + TwoPi = 2.0 * math:pi(), + NormalS = + fun + ([S0]) -> + {U0, S1} = rand:uniform_s(S0), + U1 = 1.0 - U0, + R = math:sqrt(-2.0 * math:log(U1)), + {U2, S2} = rand:uniform_s(S1), + T = TwoPi * U2, + Z0 = R * math:cos(T), + Z1 = R * math:sin(T), + {Z0, [S2|Z1]}; + ([S|Z]) -> + {Z, [S]} + end, + State = [rand:seed(exrop)], + stats_standard_normal(NormalS, State) + catch error:_ -> + {skip, "math:erfc/1 not supported"} + end. + + +stats_standard_normal(Config) when is_list(Config) -> + try math:erfc(1.0) of + _ -> + stats_standard_normal( + fun rand:normal_s/1, rand:seed_s(exrop)) + catch error:_ -> + {skip, "math:erfc/1 not supported"} + end. +%% +stats_standard_normal(Fun, S) -> +%%% +%%% ct config: +%%% {rand_SUITE, [{stats_standard_normal,[{seconds, 8}, {std_devs, 4.2}]}]}. +%%% + Seconds = ct:get_config({?MODULE, ?FUNCTION_NAME, seconds}, 8), + StdDevs = + ct:get_config( + {?MODULE, ?FUNCTION_NAME, std_devs}, + 4.2), % probability erfc(4.2/sqrt(2)) (1/37465) to fail a bucket +%%% + ct:timetrap({seconds, Seconds + 120}), + %% Buckets is chosen to get a range where the the probability to land + %% in the top catch-all bucket is not vanishingly low, but with + %% these values it is about 1/25 of the probability for the low bucket + %% (closest to 0). + %% + %% Rounds is calculated so the expected value for the low + %% bucket will be at least TargetHits. + %% + InvDelta = 512, + Buckets = 4 * InvDelta, % 4 std devs range + TargetHits = 1024, + Sqrt2 = math:sqrt(2.0), + W = InvDelta * Sqrt2, + P0 = math:erf(1 / W), + Rounds = TargetHits * ceil(1.0 / P0), + Histogram = array:new({default, 0}), + StopTime = erlang:monotonic_time(second) + Seconds, + ct:pal( + "Running standard normal test against ~w std devs for ~w seconds...", + [StdDevs, Seconds]), + {PositiveHistogram, NegativeHistogram, Outlier, TotalRounds} = + stats_standard_normal( + InvDelta, Buckets, Histogram, Histogram, 0.0, + Fun, S, Rounds, StopTime, Rounds, 0), + Precision = math:sqrt(TotalRounds * P0) / StdDevs, + TopP = math:erfc(Buckets / W), + TopPrecision = math:sqrt(TotalRounds * TopP) / StdDevs, + OutlierProbability = math:erfc(Outlier / Sqrt2) * TotalRounds, + InvOP = 1.0 / OutlierProbability, + ct:pal( + "Total rounds: ~w, tolerance: 1/~.2f..1/~.2f, " + "outlier: ~.2f, probability 1/~.2f.", + [TotalRounds, Precision, TopPrecision, Outlier, InvOP]), + {TotalRounds, [], []} = + {TotalRounds, + check_histogram( + W, TotalRounds, StdDevs, PositiveHistogram, Buckets), + check_histogram( + W, TotalRounds, StdDevs, NegativeHistogram, Buckets)}, + %% If the probability for getting this Outlier is lower than 1/50, + %% then this is fishy! + true = (1/50 =< OutlierProbability), + {comment, {tp, TopPrecision, op, InvOP}}. +%% +stats_standard_normal( + InvDelta, Buckets, PositiveHistogram, NegativeHistogram, Outlier, + Fun, S, 0, StopTime, Rounds, TotalRounds) -> + case erlang:monotonic_time(second) of + Now when Now < StopTime -> + stats_standard_normal( + InvDelta, Buckets, + PositiveHistogram, NegativeHistogram, Outlier, + Fun, S, Rounds, StopTime, Rounds, TotalRounds + Rounds); + _ -> + {PositiveHistogram, NegativeHistogram, + Outlier, TotalRounds + Rounds} + end; +stats_standard_normal( + InvDelta, Buckets, PositiveHistogram, NegativeHistogram, Outlier, + Fun, S, Count, StopTime, Rounds, TotalRounds) -> + case Fun(S) of + {X, NewS} when 0.0 =< X -> + Bucket = min(Buckets, floor(X * InvDelta)), + stats_standard_normal( + InvDelta, Buckets, + increment_bucket(Bucket, PositiveHistogram), + NegativeHistogram, max(Outlier, X), + Fun, NewS, Count - 1, StopTime, Rounds, TotalRounds); + {MinusX, NewS} -> + X = -MinusX, + Bucket = min(Buckets, floor(X * InvDelta)), + stats_standard_normal( + InvDelta, Buckets, + PositiveHistogram, + increment_bucket(Bucket, NegativeHistogram), max(Outlier, X), + Fun, NewS, Count - 1, StopTime, Rounds, TotalRounds) + end. + +increment_bucket(Bucket, Array) -> + array:set(Bucket, array:get(Bucket, Array) + 1, Array). + +check_histogram(W, Rounds, StdDevs, Histogram, Buckets) -> + %%PrevBucket = 512, + %%Bucket = PrevBucket - 1, + %%P = 0.5 * math:erfc(PrevBucket / W), + TargetP = 0.5 * math:erfc(Buckets / W), + P = 0.0, + N = 0, + check_histogram( + W, Rounds, StdDevs, Histogram, TargetP, + Buckets, Buckets, P, N). +%% +check_histogram( + _W, _Rounds, _StdDevs, _Histogram, _TargetP, + 0, _PrevBucket, _PrevP, _PrevN) -> + []; +check_histogram( + W, Rounds, StdDevs, Histogram, TargetP, + Bucket, PrevBucket, PrevP, PrevN) -> + N = PrevN + array:get(Bucket, Histogram), + P = 0.5 * math:erfc(Bucket / W), + BucketP = P - PrevP, + if + TargetP =< BucketP -> + check_histogram( + W, Rounds, StdDevs, Histogram, TargetP, + Bucket - 1, PrevBucket, PrevP, N); + true -> + Exp = BucketP * Rounds, + Var = Rounds * BucketP*(1.0 - BucketP), + Threshold = StdDevs * math:sqrt(Var), + LowerLimit = floor(Exp - Threshold), + UpperLimit = ceil(Exp + Threshold), + if + N < LowerLimit; UpperLimit < N -> + [#{bucket => {Bucket, PrevBucket}, n => N, exp => Exp, + lower => LowerLimit, upper => UpperLimit} | + check_histogram( + W, Rounds, StdDevs, Histogram, TargetP, + Bucket - 1, Bucket, P, 0)]; + true -> + check_histogram( + W, Rounds, StdDevs, Histogram, TargetP, + Bucket - 1, Bucket, P, 0) + end + end. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% White box test of the conversion to float diff --git a/lib/stdlib/test/shell_SUITE.erl b/lib/stdlib/test/shell_SUITE.erl index 217e8cc252..ca85314775 100644 --- a/lib/stdlib/test/shell_SUITE.erl +++ b/lib/stdlib/test/shell_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2004-2017. All Rights Reserved. +%% Copyright Ericsson AB 2004-2018. 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. @@ -561,9 +561,10 @@ otp_5226(Config) when is_list(Config) -> otp_5327(Config) when is_list(Config) -> "exception error: bad argument" = comm_err(<<"<<\"hej\":default>>.">>), + L1 = erl_anno:new(1), <<"abc">> = - erl_parse:normalise({bin,1,[{bin_element,1,{string,1,"abc"}, - default,default}]}), + erl_parse:normalise({bin,L1,[{bin_element,L1,{string,L1,"abc"}, + default,default}]}), [<<"abc">>] = scan(<<"<<(<<\"abc\">>):3/binary>>.">>), [<<"abc">>] = scan(<<"<<(<<\"abc\">>)/binary>>.">>), "exception error: bad argument" = @@ -576,9 +577,9 @@ otp_5327(Config) when is_list(Config) -> comm_err(<<"<<10:default>>.">>), [<<98,1:1>>] = scan(<<"<<3:3,5:6>>.">>), {'EXIT',{badarg,_}} = - (catch erl_parse:normalise({bin,1,[{bin_element,1,{integer,1,17}, - {atom,1,all}, - default}]})), + (catch erl_parse:normalise({bin,L1,[{bin_element,L1,{integer,L1,17}, + {atom,L1,all}, + default}]})), [<<-20/signed>>] = scan(<<"<<-20/signed>> = <<-20>>.">>), [<<-300:16/signed>>] = scan(<<"<<-300:16/signed>> = <<-300:16>>.">>), @@ -2784,7 +2785,7 @@ otp_10302(Config) when is_list(Config) -> <<"begin A = <<\"\\xaa\">>, S = lists:flatten(io_lib:format(\"~p/~p.\", [A, A])), - {ok, Ts, _} = erl_scan:string(S, 1, [unicode]), + {ok, Ts, _} = erl_scan:string(S, 1), {ok, Es} = erl_parse:parse_exprs(Ts), B = erl_eval:new_bindings(), erl_eval:exprs(Es, B) @@ -2797,7 +2798,7 @@ otp_10302(Config) when is_list(Config) -> <<"io:setopts([{encoding,utf8}]). A = <<\"\\xaa\">>, S = lists:flatten(io_lib:format(\"~p/~p.\", [A, A])), - {ok, Ts, _} = erl_scan:string(S, 1, [unicode]), + {ok, Ts, _} = erl_scan:string(S, 1), {ok, Es} = erl_parse:parse_exprs(Ts), B = erl_eval:new_bindings(), erl_eval:exprs(Es, B).">>, @@ -2809,7 +2810,7 @@ otp_10302(Config) when is_list(Config) -> <<"begin A = [1089], S = lists:flatten(io_lib:format(\"~tp/~tp.\", [A, A])), - {ok, Ts, _} = erl_scan:string(S, 1, [unicode]), + {ok, Ts, _} = erl_scan:string(S, 1), {ok, Es} = erl_parse:parse_exprs(Ts), B = erl_eval:new_bindings(), erl_eval:exprs(Es, B) @@ -2821,7 +2822,7 @@ otp_10302(Config) when is_list(Config) -> <<"io:setopts([{encoding,utf8}]). A = [1089], S = lists:flatten(io_lib:format(\"~tp/~tp.\", [A, A])), - {ok, Ts, _} = erl_scan:string(S, 1, [unicode]), + {ok, Ts, _} = erl_scan:string(S, 1), {ok, Es} = erl_parse:parse_exprs(Ts), B = erl_eval:new_bindings(), erl_eval:exprs(Es, B).">>, @@ -2940,7 +2941,7 @@ otp_14296(Config) when is_list(Config) -> end(), fun() -> - Port = open_port({spawn, "ls"}, [line]), + Port = open_port({spawn, "ls"}, [{line,1}]), KnownPort = erlang:port_to_list(Port), S = KnownPort ++ ".", R = KnownPort ++ ".\n", @@ -3012,7 +3013,7 @@ scan(B) -> scan(t(B), F). scan(S0, F) -> - case erl_scan:tokens([], S0, 1, [unicode]) of + case erl_scan:tokens([], S0, 1) of {done,{ok,Ts,_},S} -> [F(Ts) | scan(S, F)]; _Else -> diff --git a/lib/stdlib/test/stdlib.spec b/lib/stdlib/test/stdlib.spec index 91712b8963..9c625091a8 100644 --- a/lib/stdlib/test/stdlib.spec +++ b/lib/stdlib/test/stdlib.spec @@ -1,2 +1,4 @@ {suites,"../stdlib_test",all}. -{skip_suites,"../stdlib_test",stdlib_bench_SUITE, "bench only"}. +{skip_groups,"../stdlib_test",stdlib_bench_SUITE, + [base64,gen_server,gen_statem,unicode], + "Benchmark only"}. diff --git a/lib/stdlib/test/stdlib_bench.spec b/lib/stdlib/test/stdlib_bench.spec index a5d1e1db80..7a0da811a0 100644 --- a/lib/stdlib/test/stdlib_bench.spec +++ b/lib/stdlib/test/stdlib_bench.spec @@ -5,3 +5,6 @@ {skip_suites,"../stdlib_test",string_SUITE, "bench only"}. {suites,"../stdlib_test",[stdlib_bench_SUITE]}. +{skip_groups,"../stdlib_test",stdlib_bench_SUITE, + [gen_server_comparison,gen_statem_comparison], + "Not a benchmark"}. diff --git a/lib/stdlib/test/stdlib_bench_SUITE.erl b/lib/stdlib/test/stdlib_bench_SUITE.erl index 8670e7029c..294898a932 100644 --- a/lib/stdlib/test/stdlib_bench_SUITE.erl +++ b/lib/stdlib/test/stdlib_bench_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2012-2016. All Rights Reserved. +%% Copyright Ericsson AB 2012-2018. 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. @@ -21,6 +21,7 @@ %% -module(stdlib_bench_SUITE). -compile([export_all, nowarn_export_all]). +-include_lib("common_test/include/ct.hrl"). -include_lib("common_test/include/ct_event.hrl"). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -28,14 +29,55 @@ suite() -> [{ct_hooks,[{ts_install_cth,[{nodenames,2}]}]}]. all() -> - [{group,unicode}]. + [{group,unicode},{group,base64}, + {group,gen_server},{group,gen_statem}, + {group,gen_server_comparison},{group,gen_statem_comparison}]. groups() -> [{unicode,[{repeat,5}], [norm_nfc_list, norm_nfc_deep_l, norm_nfc_binary, string_lexemes_list, string_lexemes_binary - ]}]. + ]}, + {base64,[{repeat,5}], + [decode_binary, decode_binary_to_string, + decode_list, decode_list_to_string, + encode_binary, encode_binary_to_string, + encode_list, encode_list_to_string, + mime_binary_decode, mime_binary_decode_to_string, + mime_list_decode, mime_list_decode_to_string]}, + {gen_server, [{repeat,5}], cases(gen_server)}, + {gen_statem, [{repeat,3}], cases(gen_statem)}, + {gen_server_comparison, [], + [single_small, single_medium, single_big, + sched_small, sched_medium, sched_big, + multi_small, multi_medium, multi_big]}, + {gen_statem_comparison, [], + [single_small, single_big, + sched_small, sched_big, + multi_small, multi_big]}]. +cases(gen_server) -> + [simple, simple_timer, simple_mon, simple_timer_mon, + generic, generic_timer]; +cases(gen_statem) -> + [generic, generic_fsm, generic_fsm_transit, + generic_statem, generic_statem_transit, + generic_statem_complex]. + +init_per_group(gen_server, Config) -> + compile_servers(Config), + [{benchmark_suite,"stdlib_gen_server"}|Config]; +init_per_group(gen_statem, Config) -> + compile_servers(Config), + [{benchmark_suite,"stdlib_gen_statem"}|Config]; +init_per_group(gen_server_comparison, Config) -> + compile_servers(Config), + [{cases,cases(gen_server)}, + {benchmark_suite,"stdlib_gen_server"}|Config]; +init_per_group(gen_statem_comparison, Config) -> + compile_servers(Config), + [{cases,cases(gen_statem)}, + {benchmark_suite,"stdlib_gen_statem"}|Config]; init_per_group(_GroupName, Config) -> Config. @@ -55,23 +97,33 @@ end_per_testcase(_Func, _Conf) -> ok. +compile_servers(Config) -> + DataDir = ?config(data_dir, Config), + Files = filelib:wildcard(filename:join(DataDir, "{simple,generic}*.erl")), + _ = [{ok, _} = compile:file(File) || File <- Files], + ok. + +comment(Value) -> + C = lists:flatten(io_lib:format("~p", [Value])), + {comment, C}. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -define(REPEAT_NORM, 5). norm_nfc_list(Config) -> Bin = norm_data(Config), {_N, Mean, _Stddev, Res} = unicode_util_SUITE:time_count(nfc, list, Bin, ?REPEAT_NORM), - report(1000.0*Res / Mean). + comment(report(1000.0*Res / Mean)). norm_nfc_deep_l(Config) -> Bin = norm_data(Config), {_N, Mean, _Stddev, Res} = unicode_util_SUITE:time_count(nfc, deep_l, Bin, ?REPEAT_NORM), - report(1000.0*Res / Mean). + comment(report(1000.0*Res / Mean)). norm_nfc_binary(Config) -> Bin = norm_data(Config), {_N, Mean, _Stddev, Res} = unicode_util_SUITE:time_count(nfc, binary, Bin, ?REPEAT_NORM), - report(1000.0*Res / Mean). + comment(report(1000.0*Res / Mean)). string_lexemes_list(Config) -> @@ -80,7 +132,7 @@ string_lexemes_list(Config) -> Bin = norm_data(Config), Fun = fun(Str) -> string:nth_lexeme(Str, 200000, [$;,$\n,$\r]), 200000 end, {_N, Mean, _Stddev, Res} = string_SUITE:time_func(Fun, list, Bin, 15), - report(1000.0*Res / Mean). + comment(report(1000.0*Res / Mean)). string_lexemes_binary(Config) -> %% Use nth_lexeme instead of lexemes to avoid building a result of @@ -88,7 +140,7 @@ string_lexemes_binary(Config) -> Bin = norm_data(Config), Fun = fun(Str) -> string:nth_lexeme(Str, 200000, [$;,$\n,$\r]), 200000 end, {_N, Mean, _Stddev, Res} = string_SUITE:time_func(Fun, binary, Bin, ?REPEAT_NORM), - report(1000.0*Res / Mean). + comment(report(1000.0*Res / Mean)). %%% report(Tps) -> @@ -105,3 +157,386 @@ norm_data(Config) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +decode_binary(_Config) -> + comment(test(decode, encoded_binary())). + +decode_binary_to_string(_Config) -> + comment(test(decode_to_string, encoded_binary())). + +decode_list(_Config) -> + comment(test(decode, encoded_list())). + +decode_list_to_string(_Config) -> + comment(test(decode_to_string, encoded_list())). + +encode_binary(_Config) -> + comment(test(encode, binary())). + +encode_binary_to_string(_Config) -> + comment(test(encode_to_string, binary())). + +encode_list(_Config) -> + comment(test(encode, list())). + +encode_list_to_string(_Config) -> + comment(test(encode_to_string, list())). + +mime_binary_decode(_Config) -> + comment(test(mime_decode, encoded_binary())). + +mime_binary_decode_to_string(_Config) -> + comment(test(mime_decode_to_string, encoded_binary())). + +mime_list_decode(_Config) -> + comment(test(mime_decode, encoded_list())). + +mime_list_decode_to_string(_Config) -> + comment(test(mime_decode_to_string, encoded_list())). + +-define(SIZE, 10000). +-define(N, 1000). + +encoded_binary() -> + list_to_binary(encoded_list()). + +encoded_list() -> + L = random_byte_list(round(?SIZE*0.75)), + base64:encode_to_string(L). + +binary() -> + list_to_binary(list()). + +list() -> + random_byte_list(?SIZE). + +test(Func, Data) -> + F = fun() -> loop(?N, Func, Data) end, + {Time, ok} = timer:tc(fun() -> lspawn(F) end), + report_base64(Time). + +loop(0, _F, _D) -> garbage_collect(), ok; +loop(N, F, D) -> + _ = base64:F(D), + loop(N - 1, F, D). + +lspawn(Fun) -> + {Pid, Ref} = spawn_monitor(fun() -> exit(Fun()) end), + receive + {'DOWN', Ref, process, Pid, Rep} -> Rep + end. + +report_base64(Time) -> + Tps = round((?N*1000000)/Time), + ct_event:notify(#event{name = benchmark_data, + data = [{suite, "stdlib_base64"}, + {value, Tps}]}), + Tps. + +%% Copied from base64_SUITE.erl. + +random_byte_list(N) -> + random_byte_list(N, []). + +random_byte_list(0, Acc) -> + Acc; +random_byte_list(N, Acc) -> + random_byte_list(N-1, [rand:uniform(255)|Acc]). + +make_big_binary(N) -> + list_to_binary(mbb(N, [])). + +mbb(N, Acc) when N > 256 -> + B = list_to_binary(lists:seq(0, 255)), + mbb(N - 256, [B | Acc]); +mbb(N, Acc) -> + B = list_to_binary(lists:seq(0, N-1)), + lists:reverse(Acc, B). + +simple(Config) when is_list(Config) -> + comment(do_tests(simple, single_small, Config)). + +simple_timer(Config) when is_list(Config) -> + comment(do_tests(simple_timer, single_small, Config)). + +simple_mon(Config) when is_list(Config) -> + comment(do_tests(simple_mon, single_small, Config)). + +simple_timer_mon(Config) when is_list(Config) -> + comment(do_tests(simple_timer_mon, single_small, Config)). + +generic(Config) when is_list(Config) -> + comment(do_tests(generic, single_small, Config)). + +generic_timer(Config) when is_list(Config) -> + comment(do_tests(generic_timer, single_small, Config)). + +generic_statem(Config) when is_list(Config) -> + comment(do_tests(generic_statem, single_small, Config)). + +generic_statem_transit(Config) when is_list(Config) -> + comment(do_tests(generic_statem_transit, single_small, Config)). + +generic_statem_complex(Config) when is_list(Config) -> + comment(do_tests(generic_statem_complex, single_small, Config)). + +generic_fsm(Config) when is_list(Config) -> + comment(do_tests(generic_fsm, single_small, Config)). + +generic_fsm_transit(Config) when is_list(Config) -> + comment(do_tests(generic_fsm_transit, single_small, Config)). + +single_small(Config) when is_list(Config) -> + comparison(?config(cases, Config), single_small, Config). + +single_medium(Config) when is_list(Config) -> + comparison(?config(cases, Config), single_medium, Config). + +single_big(Config) when is_list(Config) -> + comparison(?config(cases, Config), single_big, Config). + +sched_small(Config) when is_list(Config) -> + comparison(?config(cases, Config), sched_small, Config). + +sched_medium(Config) when is_list(Config) -> + comparison(?config(cases, Config), sched_medium, Config). + +sched_big(Config) when is_list(Config) -> + comparison(?config(cases, Config), sched_big, Config). + +multi_small(Config) when is_list(Config) -> + comparison(?config(cases, Config), multi_small, Config). + +multi_medium(Config) when is_list(Config) -> + comparison(?config(cases, Config), multi_medium, Config). + +multi_big(Config) when is_list(Config) -> + comparison(?config(cases, Config), multi_big, Config). + +comparison(Cases, Kind, Config) -> + Cases = ?config(cases, Config), + [RefResult|_] = Results = + [do_tests(Case, Kind, Config) || Case <- Cases], + Normalized = [norm(Result, RefResult) || Result <- Results], + {Parallelism, Message} = bench_params(Kind), + Wordsize = erlang:system_info(wordsize), + MSize = Wordsize * erts_debug:flat_size(Message), + What = io_lib:format("#parallel gen_server instances: ~.4w, " + "message flat size: ~.5w bytes", + [Parallelism, MSize]), + Format = + lists:flatten( + ["~s: "] ++ + [[atom_to_list(Case),": ~s "] || Case <- Cases]), + C = lists:flatten(io_lib:format(Format, [What] ++ Normalized)), + {comment, C}. + +norm(T, Ref) -> + try Ref / T of + Norm -> + io_lib:format("~.2f", [Norm]) + catch error:badarith -> + "---" + end. + +-define(MAX_TIME_SECS, 3). % s +-define(MAX_TIME, 1000 * ?MAX_TIME_SECS). % ms +-define(CALLS_PER_LOOP, 5). + +do_tests(Test, ParamSet, Config) -> + BenchmarkSuite = ?config(benchmark_suite, Config), + {Client, ServerMod} = bench(Test), + {Parallelism, Message} = bench_params(ParamSet), + Fun = create_clients(Message, ServerMod, Client, Parallelism), + {TotalLoops, AllPidTime} = run_test(Fun), + PerSecond = ?CALLS_PER_LOOP * round((1000 * TotalLoops) / AllPidTime), + ct_event:notify( + #event{ + name = benchmark_data, + data = [{suite,BenchmarkSuite},{value,PerSecond}]}), + PerSecond. + +-define(COUNTER, n). + +simple_client(N, M, P) -> + put(?COUNTER, N), + _ = simple_server:reply(P, M), + _ = simple_server:reply(P, M), + _ = simple_server:reply(P, M), + _ = simple_server:reply(P, M), + _ = simple_server:reply(P, M), + simple_client(N+1, M, P). + +simple_client_timer(N, M, P) -> + put(?COUNTER, N), + _ = simple_server_timer:reply(P, M), + _ = simple_server_timer:reply(P, M), + _ = simple_server_timer:reply(P, M), + _ = simple_server_timer:reply(P, M), + _ = simple_server_timer:reply(P, M), + simple_client_timer(N+1, M, P). + +simple_client_mon(N, M, P) -> + put(?COUNTER, N), + _ = simple_server_mon:reply(P, M), + _ = simple_server_mon:reply(P, M), + _ = simple_server_mon:reply(P, M), + _ = simple_server_mon:reply(P, M), + _ = simple_server_mon:reply(P, M), + simple_client_mon(N+1, M, P). + +simple_client_timer_mon(N, M, P) -> + put(?COUNTER, N), + _ = simple_server_timer_mon:reply(P, M), + _ = simple_server_timer_mon:reply(P, M), + _ = simple_server_timer_mon:reply(P, M), + _ = simple_server_timer_mon:reply(P, M), + _ = simple_server_timer_mon:reply(P, M), + simple_client_timer_mon(N+1, M, P). + +generic_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_server:reply(P, M), + _ = generic_server:reply(P, M), + _ = generic_server:reply(P, M), + _ = generic_server:reply(P, M), + _ = generic_server:reply(P, M), + generic_client(N+1, M, P). + +generic_timer_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_server_timer:reply(P, M), + _ = generic_server_timer:reply(P, M), + _ = generic_server_timer:reply(P, M), + _ = generic_server_timer:reply(P, M), + _ = generic_server_timer:reply(P, M), + generic_timer_client(N+1, M, P). + +generic_statem_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + generic_statem_client(N+1, M, P). + +generic_statem_transit_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_statem:transit(P, M), + _ = generic_statem:transit(P, M), + _ = generic_statem:transit(P, M), + _ = generic_statem:transit(P, M), + _ = generic_statem:transit(P, M), + generic_statem_transit_client(N+1, M, P). + +generic_statem_complex_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + generic_statem_complex_client(N+1, M, P). + +generic_fsm_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_fsm:reply(P, M), + _ = generic_fsm:reply(P, M), + _ = generic_fsm:reply(P, M), + _ = generic_fsm:reply(P, M), + _ = generic_fsm:reply(P, M), + generic_fsm_client(N+1, M, P). + +generic_fsm_transit_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_fsm:transit(P, M), + _ = generic_fsm:transit(P, M), + _ = generic_fsm:transit(P, M), + _ = generic_fsm:transit(P, M), + _ = generic_fsm:transit(P, M), + generic_fsm_transit_client(N+1, M, P). + +bench(simple) -> + {fun simple_client/3, simple_server}; +bench(simple_timer) -> + {fun simple_client_timer/3, simple_server_timer}; +bench(simple_mon) -> + {fun simple_client_mon/3, simple_server_mon}; +bench(simple_timer_mon) -> + {fun simple_client_timer_mon/3, simple_server_timer_mon}; +bench(generic) -> + {fun generic_client/3, generic_server}; +bench(generic_timer) -> + {fun generic_timer_client/3, generic_server_timer}; +bench(generic_statem) -> + {fun generic_statem_client/3, generic_statem}; +bench(generic_statem_transit) -> + {fun generic_statem_transit_client/3, generic_statem}; +bench(generic_statem_complex) -> + {fun generic_statem_complex_client/3, generic_statem_complex}; +bench(generic_fsm) -> + {fun generic_fsm_client/3, generic_fsm}; +bench(generic_fsm_transit) -> + {fun generic_fsm_transit_client/3, generic_fsm}. + +%% -> {Parallelism, MessageTerm} +bench_params(single_small) -> {1, small()}; +bench_params(single_medium) -> {1, medium()}; +bench_params(single_big) -> {1, big()}; +bench_params(sched_small) -> {parallelism(), small()}; +bench_params(sched_medium) -> {parallelism(), medium()}; +bench_params(sched_big) -> {parallelism(), big()}; +bench_params(multi_small) -> {400, small()}; +bench_params(multi_medium) -> {400, medium()}; +bench_params(multi_big) -> {400, big()}. + +small() -> + small. + +medium() -> + lists:seq(1, 50). + +big() -> + lists:seq(1, 1000). + +parallelism() -> + case erlang:system_info(multi_scheduling) of + enabled -> erlang:system_info(schedulers_online); + _ -> 1 + end. + +create_clients(M, ServerMod, Client, Parallel) -> + fun() -> + State = term, + ServerPid = ServerMod:start(State), + PidRefs = [spawn_monitor(fun() -> Client(0, M, ServerPid) end) || + _ <- lists:seq(1, Parallel)], + timer:sleep(?MAX_TIME), + try + AllPidsN = collect(PidRefs, []), + TotalLoops = lists:sum(AllPidsN), + TotalLoops + after + ok = ServerMod:stop(ServerPid) + end + end. + +collect([], Result) -> + Result; +collect([{Pid, Ref}|PidRefs], Result) -> + N = case erlang:process_info(Pid, dictionary) of + {dictionary, Dict} -> + {?COUNTER, N0} = lists:keyfind(?COUNTER, 1, Dict), + N0; + undefined -> % Process did not start in ?MAX_TIME_SECS. + 0 + end, + exit(Pid, kill), + receive {'DOWN', Ref, _, _, _} -> ok end, + collect(PidRefs, [N|Result]). + +run_test(Test) -> + {T1, _} = statistics(runtime), + Result = Test(), + {T2, _} = statistics(runtime), + {Result, T2 - T1}. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/generic_fsm.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_fsm.erl new file mode 100644 index 0000000000..50f7df7a2a --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_fsm.erl @@ -0,0 +1,59 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017-2018. 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(generic_fsm). + +-export([start/1, reply/2, transit/2, stop/1]). + +-export([init/1, terminate/3]). +-export([state1/3, state2/3]). + +-behaivour(gen_fsm). + + +%% API + +start(Data) -> + {ok, Pid} = gen_fsm:start(?MODULE, Data, []), + Pid. + +stop(P) -> + ok = gen_fsm:stop(P). + +reply(S, M) -> + gen_fsm:sync_send_event(S, {reply, M}, infinity). + +transit(S, M) -> + gen_fsm:sync_send_event(S, {transit, M}, infinity). + +%% Implementation + +init(Data) -> + {ok, state1, Data}. + +terminate(_Reason, _State, _Data) -> + ok. + +state1({reply, M}, _From, Data) -> + {reply, M, ?FUNCTION_NAME, Data}; +state1({transit, M}, _From, Data) -> + {reply, M, state2, Data}. + +state2({transit, M}, _From, Data) -> + {reply, M, state1, Data}. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/generic_server.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_server.erl new file mode 100644 index 0000000000..abd61dcdef --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_server.erl @@ -0,0 +1,31 @@ +-module(generic_server). + +-export([start/1, reply/2, stop/1]). + +-export([handle_call/3, handle_cast/2, init/1, terminate/2]). + +-behaviour(gen_server). + +-define(GEN_SERVER, gen_server). + +start(State) -> + {ok, Pid} = ?GEN_SERVER:start(?MODULE, State, []), + Pid. + +init(State) -> + {ok, State}. + +stop(P) -> + ok = ?GEN_SERVER:stop(P). + +reply(S, M) -> + _M = ?GEN_SERVER:call(S, {reply, M}, infinity). + +handle_call({reply, M}, _From, State) -> + {reply, M, State}. + +handle_cast(_Msg, State) -> + {noreply, State}. + +terminate(_Reason, _State) -> + ok. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/generic_server_timer.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_server_timer.erl new file mode 100644 index 0000000000..0faa30207d --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_server_timer.erl @@ -0,0 +1,31 @@ +-module(generic_server_timer). + +-export([start/1, reply/2, stop/1]). + +-export([handle_call/3, handle_cast/2, init/1, terminate/2]). + +-behaviour(gen_server). + +-define(GEN_SERVER, gen_server). + +start(State) -> + {ok, Pid} = ?GEN_SERVER:start(?MODULE, State, []), + Pid. + +init(State) -> + {ok, State}. + +stop(P) -> + ok = ?GEN_SERVER:stop(P). + +reply(S, M) -> + ?GEN_SERVER:call(S, {reply, M}). + +handle_call({reply, M}, _From, State) -> + {reply, M, State}. + +handle_cast(_Msg, State) -> + {noreply, State}. + +terminate(_Reason, _State) -> + ok. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem.erl new file mode 100644 index 0000000000..2e0491f060 --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem.erl @@ -0,0 +1,58 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017-2018. 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(generic_statem). + +-export([start/1, reply/2, transit/2, stop/1]). + +-export([callback_mode/0, init/1]). +-export([state1/3, state2/3]). + +-behaviour(gen_statem). + +%% API + +start(Data) -> + {ok, Pid} = gen_statem:start(?MODULE, Data, []), + Pid. + +stop(P) -> + ok = gen_statem:stop(P). + +reply(S, M) -> + gen_statem:call(S, {reply, M}, infinity). + +transit(S, M) -> + gen_statem:call(S, {transit, M}, infinity). + +%% Implementation + +callback_mode() -> + state_functions. + +init(Data) -> + {ok, state1, Data}. + +state1({call, From}, {reply, M}, Data) -> + {keep_state, Data, {reply, From, M}}; +state1({call, From}, {transit, M}, Data) -> + {next_state, state2, Data, {reply, From, M}}. + +state2({call, From}, {transit, M}, Data) -> + {next_state, state1, Data, {reply, From, M}}. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem_complex.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem_complex.erl new file mode 100644 index 0000000000..983227d281 --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem_complex.erl @@ -0,0 +1,66 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017-2018. 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(generic_statem_complex). + +-export([start/1, reply/2, stop/1]). + +-export([callback_mode/0, init/1]). +-export([state1/3, state2/3, state3/3]). + +-behaviour(gen_statem). + +%% API + +start(Data) -> + {ok, Pid} = gen_statem:start(?MODULE, Data, []), + Pid. + +stop(P) -> + ok = gen_statem:stop(P). + +reply(S, M) -> + gen_statem:call(S, {reply, M}, infinity). + +%% Implementation + +callback_mode() -> + [state_functions,state_enter]. + +init(Data) -> + {ok, state1, Data}. + +state1(enter, _, Data) -> + {keep_state, Data, + {state_timeout, 5000, t1}}; +state1({call, _From}, {reply, _M}, Data) -> + {next_state, state2, Data, + [postpone,{next_event,internal,e}]}. + +state2(enter, _, _Data) -> + keep_state_and_data; +state2(internal, e, Data) -> + {next_state, state3, Data}. + +state3(enter, _, Data) -> + {keep_state, Data, + {state_timeout, 5000, t3}}; +state3({call, From}, {reply, M}, Data) -> + {next_state, state1, Data, + {reply, From, M}}. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server.erl new file mode 100644 index 0000000000..bd43f686e8 --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server.erl @@ -0,0 +1,31 @@ +-module(simple_server). + +%% Local process. No timer. No monitor. + +-export([start/1, reply/2, stop/1]). + +start(State) -> + spawn(fun() -> loop(State) end). + +stop(P) -> + P ! {stop, self()}, + receive + ok -> + ok + end. + +loop(S) -> + receive + {reply, P, M} -> + P ! M, + loop(S); + {stop, P} -> + P ! ok + end. + +reply(P, M) -> + P ! {reply, self(), M}, + receive + M -> + M + end. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_mon.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_mon.erl new file mode 100644 index 0000000000..9b5ace5586 --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_mon.erl @@ -0,0 +1,33 @@ +-module(simple_server_mon). + +%% Local process. No timer. Monitor. + +-export([start/1, reply/2, stop/1]). + +start(State) -> + spawn(fun() -> loop(State) end). + +stop(P) -> + P ! {stop, self()}, + receive + ok -> + ok + end. + +loop(S) -> + receive + {reply, P, Mref, M} -> + P ! {ok, Mref, M}, + loop(S); + {stop, P} -> + P ! ok + end. + +reply(P, M) -> + Mref = erlang:monitor(process, P), + P ! {reply, self(), Mref, M}, + receive + {ok, Mref, M} -> + erlang:demonitor(Mref, [flush]), + ok + end. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_timer.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_timer.erl new file mode 100644 index 0000000000..82381e1fdf --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_timer.erl @@ -0,0 +1,33 @@ +-module(simple_server_timer). + +%% Local process. Timer. No monitor. + +-export([start/1, reply/2, stop/1]). + +start(State) -> + spawn(fun() -> loop(State) end). + +stop(P) -> + P ! {stop, self()}, + receive + ok -> + ok + end. + +loop(S) -> + receive + {reply, P, M} -> + P ! M, + loop(S); + {stop, P} -> + P ! ok + end. + +reply(P, M) -> + P ! {reply, self(), M}, + receive + M -> + M + after 100 -> + exit(fel) + end. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_timer_mon.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_timer_mon.erl new file mode 100644 index 0000000000..6124ca29c2 --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/simple_server_timer_mon.erl @@ -0,0 +1,35 @@ +-module(simple_server_timer_mon). + +%% Local process. Timer. Monitor. + +-export([start/1, reply/2, stop/1]). + +start(State) -> + spawn(fun() -> loop(State) end). + +stop(P) -> + P ! {stop, self()}, + receive + ok -> + ok + end. + +loop(S) -> + receive + {reply, P, Mref, M} -> + P ! {ok, Mref, M}, + loop(S); + {stop, P} -> + P ! ok + end. + +reply(P, M) -> + Mref = erlang:monitor(process, P), + P ! {reply, self(), Mref, M}, + receive + {ok, Mref, M} -> + erlang:demonitor(Mref, [flush]), + ok + after 100 -> + exit(fel) + end. diff --git a/lib/stdlib/test/string_SUITE.erl b/lib/stdlib/test/string_SUITE.erl index 05f18ef238..d02a6eac0a 100644 --- a/lib/stdlib/test/string_SUITE.erl +++ b/lib/stdlib/test/string_SUITE.erl @@ -48,6 +48,7 @@ %% Run tests when debugging them -export([debug/0, time_func/4]). +-compile([nowarn_deprecated_function]). suite() -> [{ct_hooks,[ts_install_cth]}, @@ -92,14 +93,11 @@ end_per_testcase(_Case, _Config) -> ok. debug() -> - Config = [{data_dir, ?MODULE_STRING++"_data"}], + Config = [{data_dir, "./" ++ ?MODULE_STRING++"_data"}], [io:format("~p:~p~n",[Test,?MODULE:Test(Config)]) || {_,Tests} <- groups(), Test <- Tests]. -define(TEST(B,C,D), test(?LINE,?FUNCTION_NAME,B,C,D, true)). --define(TEST_EQ(B,C,D), - test(?LINE,?FUNCTION_NAME,B,C,D, true), - test(?LINE,?FUNCTION_NAME,hd(C),[B|tl(C),D, true)). -define(TEST_NN(B,C,D), test(?LINE,?FUNCTION_NAME,B,C,D, false), @@ -294,6 +292,7 @@ trim(_) -> ?TEST(["..h", ".e", <<"j..">>], [both, ". "], "h.ej"), ?TEST(["..h", <<".ejsa"/utf8>>, "n.."], [both, ". "], "h.ejsan"), %% Test that it behaves with graphemes (i.e. nfd tests are the hard part) + ?TEST([1013,101,778,101,101], [trailing, [101]], [1013,101,778]), ?TEST("aaåaa", [both, "a"], "å"), ?TEST(["aaa",778,"äöoo"], [both, "ao"], "åäö"), ?TEST([<<"aaa">>,778,"äöoo"], [both, "ao"], "åäö"), @@ -353,6 +352,7 @@ take(_) -> ?TEST([<<>>,<<"..">>, " h.ej", <<" ..">>], [Chars, true, leading], {".. ", "h.ej .."}), ?TEST(["..h", <<".ejsa"/utf8>>, "n.."], [Chars, true, leading], {"..", "h.ejsan.."}), %% Test that it behaves with graphemes (i.e. nfd tests are the hard part) + ?TEST([101,778], [[[101, 779]], true], {[101,778], []}), ?TEST(["aaee",778,"äöoo"], [[[$e,778]], true, leading], {"aae", [$e,778|"äöoo"]}), ?TEST([<<"aae">>,778,"äöoo"], [[[$e,778]],true,leading], {"aa", [$e,778|"äöoo"]}), ?TEST([<<"e">>,778,"åäöe", <<778/utf8>>], [[[$e,778]], true, leading], {[], [$e,778]++"åäöe"++[778]}), @@ -713,29 +713,123 @@ nth_lexeme(_) -> meas(Config) -> + Parent = self(), + Exec = fun() -> + DataDir0 = proplists:get_value(data_dir, Config), + DataDir = filename:join(lists:droplast(filename:split(DataDir0))), + case proplists:get_value(profile, Config, false) of + false -> + do_measure(DataDir); + eprof -> + eprof:profile(fun() -> do_measure(DataDir) end, [set_on_spawn]), + eprof:stop_profiling(), + eprof:analyze(), + eprof:stop() + end, + Parent ! {test_done, self()}, + normal + end, + ct:timetrap({minutes,2}), case ct:get_timetrap_info() of {_,{_,Scale}} when Scale > 1 -> {skip,{will_not_run_in_debug,Scale}}; - _ -> % No scaling - DataDir = proplists:get_value(data_dir, Config), - TestDir = filename:dirname(string:trim(DataDir, trailing, "/")), - do_measure(TestDir) + _ -> % No scaling, run at most 1.5 min + Tester = spawn(Exec), + receive {test_done, Tester} -> ok + after 90000 -> + io:format("Timelimit reached stopping~n",[]), + exit(Tester, die) + end, + ok end. -do_measure(TestDir) -> - File = filename:join(TestDir, ?MODULE_STRING ++ ".erl"), +do_measure(DataDir) -> + File = filename:join([DataDir,"unicode_util_SUITE_data","NormalizationTest.txt"]), io:format("File ~s ",[File]), {ok, Bin} = file:read_file(File), io:format("~p~n",[byte_size(Bin)]), Do = fun(Name, Func, Mode) -> - {N, Mean, Stddev, _} = time_func(Func, Mode, Bin, 50), - io:format("~10w ~6w ~6.2fms ±~4.2fms #~.2w gc included~n", + {N, Mean, Stddev, _} = time_func(Func, Mode, Bin, 20), + io:format("~15w ~6w ~6.2fms ±~5.2fms #~.2w gc included~n", [Name, Mode, Mean/1000, Stddev/1000, N]) end, + Do2 = fun(Name, Func, Mode) -> + {N, Mean, Stddev, _} = time_func(Func, binary, <<>>, 20), + io:format("~15w ~6w ~6.2fms ±~5.2fms #~.2w gc included~n", + [Name, Mode, Mean/1000, Stddev/1000, N]) + end, io:format("----------------------~n"), - Do(tokens, fun(Str) -> string:tokens(Str, [$\n,$\r]) end, list), + + Do(old_tokens, fun(Str) -> string:tokens(Str, [$\n,$\r]) end, list), Tokens = {lexemes, fun(Str) -> string:lexemes(Str, [$\n,$\r]) end}, [Do(Name,Fun,Mode) || {Name,Fun} <- [Tokens], Mode <- [list, binary]], + + S0 = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxy.....", + S0B = <<"xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxy.....">>, + Do2(old_strip_l, repeat(fun() -> string:strip(S0, left, $x) end), list), + Do2(trim_l, repeat(fun() -> string:trim(S0, leading, [$x]) end), list), + Do2(trim_l, repeat(fun() -> string:trim(S0B, leading, [$x]) end), binary), + Do2(old_strip_r, repeat(fun() -> string:strip(S0, right, $.) end), list), + Do2(trim_t, repeat(fun() -> string:trim(S0, trailing, [$.]) end), list), + Do2(trim_t, repeat(fun() -> string:trim(S0B, trailing, [$.]) end), binary), + + Do2(old_chr_sub, repeat(fun() -> string:sub_string(S0, string:chr(S0, $.)) end), list), + Do2(old_str_sub, repeat(fun() -> string:sub_string(S0, string:str(S0, [$.])) end), list), + Do2(find, repeat(fun() -> string:find(S0, [$.]) end), list), + Do2(find, repeat(fun() -> string:find(S0B, [$.]) end), binary), + Do2(old_str_sub2, repeat(fun() -> N = string:str(S0, "xy.."), + {string:sub_string(S0,1,N), string:sub_string(S0,N+4)} end), list), + Do2(split, repeat(fun() -> string:split(S0, "xy..") end), list), + Do2(split, repeat(fun() -> string:split(S0B, "xy..") end), binary), + + Do2(old_rstr_sub, repeat(fun() -> string:sub_string(S0, string:rstr(S0, [$y])) end), list), + Do2(find_t, repeat(fun() -> string:find(S0, [$y], trailing) end), list), + Do2(find_t, repeat(fun() -> string:find(S0B, [$y], trailing) end), binary), + Do2(old_rstr_sub2, repeat(fun() -> N = string:rstr(S0, "y.."), + {string:sub_string(S0,1,N), string:sub_string(S0,N+3)} end), list), + Do2(split_t, repeat(fun() -> string:split(S0, "y..", trailing) end), list), + Do2(split_t, repeat(fun() -> string:split(S0B, "y..", trailing) end), binary), + + Do2(old_span, repeat(fun() -> N=string:span(S0, [$x, $y]), + {string:sub_string(S0,1,N),string:sub_string(S0,N+1)} + end), list), + Do2(take, repeat(fun() -> string:take(S0, [$x, $y]) end), list), + Do2(take, repeat(fun() -> string:take(S0B, [$x, $y]) end), binary), + + Do2(old_cspan, repeat(fun() -> N=string:cspan(S0, [$.,$y]), + {string:sub_string(S0,1,N),string:sub_string(S0,N+1)} + end), list), + Do2(take_c, repeat(fun() -> string:take(S0, [$.,$y], true) end), list), + Do2(take_c, repeat(fun() -> string:take(S0B, [$.,$y], true) end), binary), + + Do2(old_substr, repeat(fun() -> string:substr(S0, 21, 15) end), list), + Do2(slice, repeat(fun() -> string:slice(S0, 20, 15) end), list), + Do2(slice, repeat(fun() -> string:slice(S0B, 20, 15) end), binary), + + io:format("--~n",[]), + NthTokens = {nth_lexemes, fun(Str) -> string:nth_lexeme(Str, 18000, [$\n,$\r]) end}, + [Do(Name,Fun,Mode) || {Name,Fun} <- [NthTokens], Mode <- [list, binary]], + Do2(take_t, repeat(fun() -> string:take(S0, [$.,$y], false, trailing) end), list), + Do2(take_t, repeat(fun() -> string:take(S0B, [$.,$y], false, trailing) end), binary), + Do2(take_tc, repeat(fun() -> string:take(S0, [$x], true, trailing) end), list), + Do2(take_tc, repeat(fun() -> string:take(S0B, [$x], true, trailing) end), binary), + + Length = {length, fun(Str) -> string:length(Str) end}, + [Do(Name,Fun,Mode) || {Name,Fun} <- [Length], Mode <- [list, binary]], + + Reverse = {reverse, fun(Str) -> string:reverse(Str) end}, + [Do(Name,Fun,Mode) || {Name,Fun} <- [Reverse], Mode <- [list, binary]], + + ok. + +repeat(F) -> + fun(_) -> repeat_1(F,20000) end. + +repeat_1(F, N) when N > 0 -> + F(), + repeat_1(F, N-1); +repeat_1(_, _) -> + erlang:garbage_collect(), ok. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -865,8 +959,6 @@ check_types_1({list, _},{list, undefined}) -> ok; check_types_1({list, _},{list, codepoints}) -> ok; -check_types_1({list, _},{list, {list, codepoints}}) -> - ok; check_types_1({list, {list, _}},{list, {list, codepoints}}) -> ok; check_types_1(mixed,_) -> diff --git a/lib/stdlib/test/supervisor_1.erl b/lib/stdlib/test/supervisor_1.erl index 419026749b..c3ccacc587 100644 --- a/lib/stdlib/test/supervisor_1.erl +++ b/lib/stdlib/test/supervisor_1.erl @@ -42,6 +42,8 @@ start_child(error) -> set -> gen_server:start_link(?MODULE, error, []) end; +start_child({return, Term}) -> + Term; start_child(Extra) -> {ok, Pid} = gen_server:start_link(?MODULE, normal, []), diff --git a/lib/stdlib/test/supervisor_SUITE.erl b/lib/stdlib/test/supervisor_SUITE.erl index cd2c6b0cbb..761df8eb40 100644 --- a/lib/stdlib/test/supervisor_SUITE.erl +++ b/lib/stdlib/test/supervisor_SUITE.erl @@ -39,6 +39,9 @@ sup_start_ignore_temporary_child_start_child_simple/1, sup_start_ignore_permanent_child_start_child_simple/1, sup_start_error_return/1, sup_start_fail/1, + sup_start_child_returns_error/1, + sup_start_restart_child_returns_error/1, + sup_start_child_returns_error_simple/1, sup_start_map/1, sup_start_map_simple/1, sup_start_map_faulty_specs/1, sup_stop_infinity/1, sup_stop_timeout/1, sup_stop_brutal_kill/1, @@ -65,14 +68,16 @@ simple_one_for_one_extra/1, simple_one_for_one_shutdown/1]). %% Misc tests --export([child_unlink/1, tree/1, count_children/1, +-export([child_unlink/1, tree/1, count_children/1, count_children_supervisor/1, count_restarting_children/1, get_callback_module/1, do_not_save_start_parameters_for_temporary_children/1, do_not_save_child_specs_for_temporary_children/1, simple_one_for_one_scale_many_temporary_children/1, simple_global_supervisor/1, hanging_restart_loop/1, + hanging_restart_loop_rest_for_one/1, hanging_restart_loop_simple/1, code_change/1, code_change_map/1, - code_change_simple/1, code_change_simple_map/1]). + code_change_simple/1, code_change_simple_map/1, + order_of_children/1, scale_start_stop_many_children/1]). %%------------------------------------------------------------------------- @@ -91,12 +96,15 @@ all() -> {group, normal_termination}, {group, shutdown_termination}, {group, abnormal_termination}, child_unlink, tree, - count_children, count_restarting_children, get_callback_module, + count_children, count_children_supervisor, count_restarting_children, + get_callback_module, do_not_save_start_parameters_for_temporary_children, do_not_save_child_specs_for_temporary_children, simple_one_for_one_scale_many_temporary_children, temporary_bystander, - simple_global_supervisor, hanging_restart_loop, hanging_restart_loop_simple, - code_change, code_change_map, code_change_simple, code_change_simple_map]. + simple_global_supervisor, hanging_restart_loop, + hanging_restart_loop_rest_for_one, hanging_restart_loop_simple, + code_change, code_change_map, code_change_simple, code_change_simple_map, + order_of_children, scale_start_stop_many_children]. groups() -> [{sup_start, [], @@ -105,7 +113,10 @@ groups() -> sup_start_ignore_temporary_child_start_child, sup_start_ignore_temporary_child_start_child_simple, sup_start_ignore_permanent_child_start_child_simple, - sup_start_error_return, sup_start_fail]}, + sup_start_error_return, sup_start_fail, + sup_start_child_returns_error, sup_start_restart_child_returns_error, + sup_start_child_returns_error_simple + ]}, {sup_start_map, [], [sup_start_map, sup_start_map_simple, sup_start_map_faulty_specs]}, {sup_stop, [], @@ -147,6 +158,15 @@ init_per_testcase(_Case, Config) -> Config. end_per_testcase(_Case, _Config) -> + %% Clean up to avoid unnecessary error reports in the shell + case whereis(sup_test) of + SupPid when is_pid(SupPid) -> + unlink(SupPid), + exit(SupPid,shutdown), + ok; + _ -> + error + end, ok. start_link(InitResult) -> @@ -274,6 +294,7 @@ sup_start_ignore_permanent_child_start_child_simple(Config) %% Regression test: check that the supervisor terminates without error. exit(Pid, shutdown), check_exit_reason(Pid, shutdown). + %%------------------------------------------------------------------------- %% Tests what happens if init-callback returns a invalid value. sup_start_error_return(Config) when is_list(Config) -> @@ -289,6 +310,53 @@ sup_start_fail(Config) when is_list(Config) -> check_exit_reason(Term). %%------------------------------------------------------------------------- +%% Test what happens when the start function for a child returns +%% {error,Reason} or some other term(). +sup_start_restart_child_returns_error(_Config) -> + process_flag(trap_exit, true), + Child = {child1, {supervisor_1, start_child, [error]}, + permanent, 1000, worker, []}, + {ok, _Pid} = start_link({ok, {{one_for_one, 2, 3600}, [Child]}}), + + ok = supervisor:terminate_child(sup_test, child1), + {error,{function_clause,_}} = supervisor:restart_child(sup_test,child1), + + [{child1,undefined,worker,[]}] = supervisor:which_children(sup_test), + ok. + +%%------------------------------------------------------------------------- +%% Test what happens when the start function for a child returns +%% {error,Reason} or some other term(). +sup_start_child_returns_error(_Config) -> + process_flag(trap_exit, true), + Child1 = {child1, {supervisor_1, start_child, [{return,{error,reason}}]}, + permanent, 1000, worker, []}, + Child2 = {child2, {supervisor_1, start_child, [{return,error_reason}]}, + permanent, 1000, worker, []}, + {ok, _Pid} = start_link({ok, {{one_for_one, 2, 3600}, []}}), + + {error,{reason,_}} = supervisor:start_child(sup_test,Child1), + {error,{error_reason,_}} = supervisor:start_child(sup_test,Child2), + + [] = supervisor:which_children(sup_test), + ok. + +%%------------------------------------------------------------------------- +%% Test what happens when the start function for a child returns +%% {error,Reason} - simple_one_for_one +sup_start_child_returns_error_simple(_Config) -> + process_flag(trap_exit, true), + Child = {child1, {supervisor_1, start_child, []}, + permanent, 1000, worker, []}, + {ok, _Pid} = start_link({ok, {{simple_one_for_one, 2, 3600}, [Child]}}), + + {error,reason} = supervisor:start_child(sup_test,[{return,{error,reason}}]), + {error,error_reason} = supervisor:start_child(sup_test,[{return,error_reason}]), + + [] = supervisor:which_children(sup_test), + ok. + +%%------------------------------------------------------------------------- %% Tests that the supervisor process starts correctly with map %% startspec, and that the full childspec can be read. sup_start_map(Config) when is_list(Config) -> @@ -468,7 +536,16 @@ extra_return(Config) when is_list(Config) -> [{child1, CPid3, worker, []}] = supervisor:which_children(sup_test), [1,1,0,1] = get_child_counts(sup_test), - ok. + %% Check that it can be automatically restarted + terminate(CPid3, abnormal), + [{child1, CPid4, worker, []}] = supervisor:which_children(sup_test), + [1,1,0,1] = get_child_counts(sup_test), + if (not is_pid(CPid4)) orelse CPid4=:=CPid3 -> + ct:fail({not_restarted,CPid3,CPid4}); + true -> + ok + end. + %%------------------------------------------------------------------------- %% Test API functions start_child/2, terminate_child/2, delete_child/2 %% restart_child/2, which_children/1, count_children/1. Only correct @@ -1140,7 +1217,7 @@ simple_one_for_one(Config) when is_list(Config) -> [{Id4, Pid4, _, _}|_] = supervisor:which_children(sup_test), terminate(SupPid, Pid4, Id4, abnormal), - check_exit([SupPid]). + check_exit_reason(SupPid,shutdown). %%------------------------------------------------------------------------- @@ -1378,6 +1455,11 @@ tree(Config) when is_list(Config) -> [?MODULE, {ok, {{one_for_one, 4, 3600}, []}}]}, permanent, infinity, supervisor, []}, + ChildSup3 = {supchild3, + {supervisor, start_link, + [?MODULE, {ok, {{one_for_one, 4, 3600}, []}}]}, + transient, infinity, + supervisor, []}, %% Top supervisor {ok, SupPid} = start_link({ok, {{one_for_all, 4, 3600}, []}}), @@ -1385,7 +1467,9 @@ tree(Config) when is_list(Config) -> %% Child supervisors {ok, Sup1} = supervisor:start_child(SupPid, ChildSup1), {ok, Sup2} = supervisor:start_child(SupPid, ChildSup2), - [2,2,2,0] = get_child_counts(SupPid), + {ok, _Sup3} = supervisor:start_child(SupPid, ChildSup3), + ok = supervisor:terminate_child(SupPid, supchild3), + [3,2,3,0] = get_child_counts(SupPid), %% Workers [{_, CPid2, _, _},{_, CPid1, _, _}] = @@ -1417,16 +1501,21 @@ tree(Config) when is_list(Config) -> timer:sleep(1000), - [{supchild2, NewSup2, _, _},{supchild1, NewSup1, _, _}] = + [{supchild3, NewSup3, _, _}, + {supchild2, NewSup2, _, _}, + {supchild1, NewSup1, _, _}] = supervisor:which_children(SupPid), - [2,2,2,0] = get_child_counts(SupPid), + [3,3,3,0] = get_child_counts(SupPid), [{child2, _, _, _},{child1, _, _, _}] = supervisor:which_children(NewSup1), [2,2,0,2] = get_child_counts(NewSup1), [] = supervisor:which_children(NewSup2), - [0,0,0,0] = get_child_counts(NewSup2). + [0,0,0,0] = get_child_counts(NewSup2), + + [] = supervisor:which_children(NewSup3), + [0,0,0,0] = get_child_counts(NewSup3). %%------------------------------------------------------------------------- %% Test count_children @@ -1459,6 +1548,36 @@ count_children(Config) when is_list(Config) -> [1,0,0,0] = get_child_counts(sup_test). %%------------------------------------------------------------------------- +%% Test count_children for simple_one_for_one, when children are supervisors +count_children_supervisor(Config) when is_list(Config) -> + process_flag(trap_exit, true), + Child = {child, {supervisor_1, start_child, []}, temporary, infinity, + supervisor, []}, + {ok, SupPid} = start_link({ok, {{simple_one_for_one, 2, 3600}, [Child]}}), + [supervisor:start_child(sup_test, []) || _Ignore <- lists:seq(1,1000)], + + Children = supervisor:which_children(sup_test), + ChildCount = get_child_counts(sup_test), + + [supervisor:start_child(sup_test, []) || _Ignore2 <- lists:seq(1,1000)], + + ChildCount2 = get_child_counts(sup_test), + Children2 = supervisor:which_children(sup_test), + + ChildCount3 = get_child_counts(sup_test), + Children3 = supervisor:which_children(sup_test), + + 1000 = length(Children), + [1,1000,1000,0] = ChildCount, + 2000 = length(Children2), + [1,2000,2000,0] = ChildCount2, + Children3 = Children2, + ChildCount3 = ChildCount2, + + [terminate(SupPid, Pid, child, kill) || {undefined, Pid, supervisor, _Modules} <- Children3], + [1,0,0,0] = get_child_counts(sup_test). + +%%------------------------------------------------------------------------- %% Test count_children when some children are restarting count_restarting_children(Config) when is_list(Config) -> process_flag(trap_exit, true), @@ -1577,11 +1696,11 @@ dont_save_start_parameters_for_temporary_children(simple_one_for_one = Type) -> start_children(Sup2, [LargeList], 100), start_children(Sup3, [LargeList], 100), - [{memory,Mem1}] = process_info(Sup1, [memory]), - [{memory,Mem2}] = process_info(Sup2, [memory]), - [{memory,Mem3}] = process_info(Sup3, [memory]), + Size1 = erts_debug:flat_size(sys:get_status(Sup1)), + Size2 = erts_debug:flat_size(sys:get_status(Sup2)), + Size3 = erts_debug:flat_size(sys:get_status(Sup3)), - true = (Mem3 < Mem1) and (Mem3 < Mem2), + true = (Size3 < Size1) and (Size3 < Size2), terminate(Sup1, shutdown), terminate(Sup2, shutdown), @@ -1605,11 +1724,11 @@ dont_save_start_parameters_for_temporary_children(Type) -> start_children(Sup2, Transient, 100), start_children(Sup3, Temporary, 100), - [{memory,Mem1}] = process_info(Sup1, [memory]), - [{memory,Mem2}] = process_info(Sup2, [memory]), - [{memory,Mem3}] = process_info(Sup3, [memory]), + Size1 = erts_debug:flat_size(sys:get_status(Sup1)), + Size2 = erts_debug:flat_size(sys:get_status(Sup2)), + Size3 = erts_debug:flat_size(sys:get_status(Sup3)), - true = (Mem3 < Mem1) and (Mem3 < Mem2), + true = (Size3 < Size1) and (Size3 < Size2), terminate(Sup1, shutdown), terminate(Sup2, shutdown), @@ -1847,6 +1966,61 @@ hanging_restart_loop(Config) when is_list(Config) -> undefined = whereis(sup_test), ok. +hanging_restart_loop_rest_for_one(Config) when is_list(Config) -> + process_flag(trap_exit, true), + {ok, Pid} = start_link({ok, {{rest_for_one, 8, 10}, []}}), + Child1 = {child1, {supervisor_1, start_child, []}, + permanent, brutal_kill, worker, []}, + Child2 = {child2, {supervisor_deadlock, start_child, []}, + permanent, brutal_kill, worker, []}, + Child3 = {child3, {supervisor_1, start_child, []}, + permanent, brutal_kill, worker, []}, + + %% Ets table with state read by supervisor_deadlock.erl + ets:new(supervisor_deadlock,[set,named_table,public]), + ets:insert(supervisor_deadlock,{fail_start,false}), + + {ok, CPid1} = supervisor:start_child(sup_test, Child1), + {ok, CPid2} = supervisor:start_child(sup_test, Child2), + link(CPid2), + {ok, _CPid3} = supervisor:start_child(sup_test, Child3), + + ets:insert(supervisor_deadlock,{fail_start,true}), + supervisor_deadlock:restart_child(), + timer:sleep(2000), % allow restart to happen before proceeding + + {error, already_present} = supervisor:start_child(sup_test, Child2), + {error, restarting} = supervisor:restart_child(sup_test, child2), + {error, restarting} = supervisor:delete_child(sup_test, child2), + [{child3,undefined,worker,[]}, + {child2,restarting,worker,[]}, + {child1,CPid1,worker,[]}] = supervisor:which_children(sup_test), + [3,1,0,3] = get_child_counts(sup_test), + + ok = supervisor:terminate_child(sup_test, child2), + check_exit_reason(CPid2, error), + [{child3,undefined,worker,[]}, + {child2,undefined,worker,[]}, + {child1,CPid1,worker,[]}] = supervisor:which_children(sup_test), + + ets:insert(supervisor_deadlock,{fail_start,false}), + {ok, CPid22} = supervisor:restart_child(sup_test, child2), + link(CPid22), + + ets:insert(supervisor_deadlock,{fail_start,true}), + supervisor_deadlock:restart_child(), + timer:sleep(2000), % allow restart to happen before proceeding + + %% Terminating supervisor. + %% OTP-9549 fixes so this does not give a timetrap timeout - + %% i.e. that supervisor does not hang in restart loop. + terminate(Pid,shutdown), + + %% Check that child died with reason from 'restart' request above + check_exit_reason(CPid22, error), + undefined = whereis(sup_test), + ok. + %%------------------------------------------------------------------------- %% Test that child and supervisor can be shutdown while hanging in %% restart loop, simple_one_for_one. @@ -2022,11 +2196,11 @@ code_change_simple(_Config) -> SimpleChild2 = {child2,{supervisor_1, start_child, []}, permanent, brutal_kill, worker, []}, - {error, {error, {ok,[_,_]}}} = + {error, {error, {ok,{[_,_],_}}}} = fake_upgrade(SimplePid,{ok,{SimpleFlags,[SimpleChild1,SimpleChild2]}}), %% Attempt to remove child - {error, {error, {ok,[]}}} = fake_upgrade(SimplePid,{ok,{SimpleFlags,[]}}), + {error, {error, {ok,{[],_}}}} = fake_upgrade(SimplePid,{ok,{SimpleFlags,[]}}), terminate(SimplePid,shutdown), ok. @@ -2047,11 +2221,11 @@ code_change_simple_map(_Config) -> %% Attempt to add child SimpleChild2 = #{id=>child2, start=>{supervisor_1, start_child, []}}, - {error, {error, {ok, [_,_]}}} = + {error, {error, {ok, {[_,_],_}}}} = fake_upgrade(SimplePid,{ok,{SimpleFlags,[SimpleChild1,SimpleChild2]}}), %% Attempt to remove child - {error, {error, {ok, []}}} = + {error, {error, {ok, {[],_}}}} = fake_upgrade(SimplePid,{ok,{SimpleFlags,[]}}), terminate(SimplePid,shutdown), @@ -2075,6 +2249,148 @@ fake_upgrade(Pid,NewInitReturn) -> ok = sys:resume(Pid), R. +%% Test that children are started in the order they are given, and +%% terminated in the opposite order +order_of_children(_Config) -> + process_flag(trap_exit, true), + %% Use child ids that are not alphabetically storted + Id1 = ch7, + Id2 = ch3, + Id3 = ch10, + Id4 = ch2, + Id5 = ch5, + Children = + [{Id, {supervisor_1, start_child, []}, permanent, 1000, worker, []} || + Id <- [Id1,Id2,Id3,Id4,Id5]], + + {ok, SupPid} = start_link({ok, {{rest_for_one, 2, 3600}, Children}}), + + + %% Check start order (pids are growing) + Which1 = supervisor:which_children(sup_test), + IsPid = fun({_,P,_,_}) when is_pid(P) -> true; (_) -> false end, + true = lists:all(IsPid,Which1), + SortedOnPid1 = lists:keysort(2,Which1), + [{Id1,Pid1,_,_}, + {Id2,Pid2,_,_}, + {Id3,Pid3,_,_}, + {Id4,Pid4,_,_}, + {Id5,Pid5,_,_}] = SortedOnPid1, + + TPid = self(), + TraceHandler = fun({trace,P,exit,_},{Last,Ps}) when P=:=Last -> + TPid ! {exited,lists:reverse([P|Ps])}, + {Last,Ps}; + ({trace,P,exit,_},{Last,Ps}) -> + {Last,[P|Ps]}; + (_T,Acc) -> + Acc + end, + + %% Terminate Pid3 and check that Pid4 and Pid5 are terminated in + %% expected order. + Expected1 = [Pid5,Pid4], + {ok,_} = dbg:tracer(process,{TraceHandler,{Pid4,[]}}), + [{ok,[_]} = dbg:p(P,procs) || P <- Expected1], + terminate(Pid3, abnormal), + receive {exited,ExitedPids1} -> + dbg:stop_clear(), + case ExitedPids1 of + Expected1 -> ok; + _ -> ct:fail({faulty_termination_order, + {expected,Expected1}, + {got,ExitedPids1}}) + end + after 3000 -> + dbg:stop_clear(), + ct:fail({shutdown_fail,timeout}) + end, + + %% Then check that Id3-5 are started again in correct order + Which2 = supervisor:which_children(sup_test), + true = lists:all(IsPid,Which2), + SortedOnPid2 = lists:keysort(2,Which2), + [{Id1,Pid1,_,_}, + {Id2,Pid2,_,_}, + {Id3,Pid32,_,_}, + {Id4,Pid42,_,_}, + {Id5,Pid52,_,_}] = SortedOnPid2, + + %% Terminate supervisor and check that all children are terminated + %% in opposite start order + Expected2 = [Pid52,Pid42,Pid32,Pid2,Pid1], + {ok,_} = dbg:tracer(process,{TraceHandler,{Pid1,[]}}), + [{ok,[_]} = dbg:p(P,procs) || P <- Expected2], + exit(SupPid,shutdown), + receive {exited,ExitedPids2} -> + dbg:stop_clear(), + case ExitedPids2 of + Expected2 -> ok; + _ -> ct:fail({faulty_termination_order, + {expected,Expected2}, + {got,ExitedPids2}}) + end + after 3000 -> + dbg:stop_clear(), + ct:fail({shutdown_fail,timeout}) + end, + ok. + +%% Test that a non-simple supervisor scales well for starting and +%% stopping many children. +scale_start_stop_many_children(_Config) -> + process_flag(trap_exit, true), + {ok, _Pid} = start_link({ok, {{one_for_one, 2, 3600}, []}}), + N1 = 1000, + N2 = 100000, + Ids1 = lists:seq(1,N1), + Ids2 = lists:seq(1,N2), + Children1 = [{Id,{supervisor_1,start_child,[]},permanent,1000,worker,[]} || + Id <- Ids1], + Children2 = [{Id,{supervisor_1,start_child,[]},permanent,1000,worker,[]} || + Id <- Ids2], + + {StartT1,_} = + timer:tc(fun() -> + [supervisor:start_child(sup_test,C) || C <- Children1] + end), + {StopT1,_} = + timer:tc(fun() -> + [supervisor:terminate_child(sup_test,I) || I <- Ids1] + end), + ct:log("~w children, start time: ~w ms, stop time: ~w ms", + [N1, StartT1 div 1000, StopT1 div 1000]), + + {StartT2,_} = + timer:tc(fun() -> + [supervisor:start_child(sup_test,C) || C <- Children2] + end), + {StopT2,_} = + timer:tc(fun() -> + [supervisor:terminate_child(sup_test,I) || I <- Ids2] + end), + ct:log("~w children, start time: ~w ms, stop time: ~w ms", + [N2, StartT2 div 1000, StopT2 div 1000]), + + %% Scaling should be more or less linear, but allowing a bit more + %% to avoid false alarms + ScaleLimit = (N2 div N1) * 10, + StartScale = StartT2 div StartT1, + StopScale = StopT2 div StopT1, + + ct:log("Scale limit: ~w~nStart scale: ~w~nStop scale: ~w", + [ScaleLimit, StartScale, StopScale]), + + if StartScale > ScaleLimit -> + ct:fail({bad_start_scale,StartScale}); + StopScale > ScaleLimit -> + ct:fail({bad_stop_scale,StopScale}); + true -> + ok + end, + + ok. + %%------------------------------------------------------------------------- terminate(Pid, Reason) when Reason =/= supervisor -> terminate(dummy, Pid, dummy, Reason). diff --git a/lib/stdlib/test/supervisor_deadlock.erl b/lib/stdlib/test/supervisor_deadlock.erl index 8d3d1c6f30..f51aecccb2 100644 --- a/lib/stdlib/test/supervisor_deadlock.erl +++ b/lib/stdlib/test/supervisor_deadlock.erl @@ -1,5 +1,5 @@ -module(supervisor_deadlock). --compile(export_all). +-compile([export_all,nowarn_export_all]). %%%----------------------------------------------------------------- diff --git a/lib/stdlib/test/unicode_util_SUITE.erl b/lib/stdlib/test/unicode_util_SUITE.erl index 7dba0a2fd0..632d9ae6e6 100644 --- a/lib/stdlib/test/unicode_util_SUITE.erl +++ b/lib/stdlib/test/unicode_util_SUITE.erl @@ -312,12 +312,23 @@ get(_) -> add_get_tests. count(Config) -> + Parent = self(), + Exec = fun() -> + do_measure(Config), + Parent ! {test_done, self()} + end, ct:timetrap({minutes,5}), case ct:get_timetrap_info() of - {_,{_,Scale}} -> + {_,{_,Scale}} when Scale > 1 -> {skip,{measurments_skipped_debug,Scale}}; - _ -> % No scaling - do_measure(Config) + _ -> % No scaling, run at most 2 min + Tester = spawn(Exec), + receive {test_done, Tester} -> ok + after 120000 -> + io:format("Timelimit reached stopping~n",[]), + exit(Tester, die) + end, + ok end. do_measure(Config) -> diff --git a/lib/stdlib/test/uri_string_SUITE.erl b/lib/stdlib/test/uri_string_SUITE.erl new file mode 100644 index 0000000000..fef356355c --- /dev/null +++ b/lib/stdlib/test/uri_string_SUITE.erl @@ -0,0 +1,926 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2008-2017. 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(uri_string_SUITE). + +-include_lib("common_test/include/ct.hrl"). + +-export([all/0, suite/0,groups/0, + normalize/1, + parse_binary_fragment/1, parse_binary_host/1, parse_binary_host_ipv4/1, + parse_binary_host_ipv6/1, + parse_binary_path/1, parse_binary_pct_encoded_fragment/1, parse_binary_pct_encoded_query/1, + parse_binary_pct_encoded_userinfo/1, parse_binary_port/1, + parse_binary_query/1, parse_binary_scheme/1, parse_binary_userinfo/1, + parse_fragment/1, parse_host/1, parse_host_ipv4/1, parse_host_ipv6/1, + parse_path/1, parse_pct_encoded_fragment/1, parse_pct_encoded_query/1, + parse_pct_encoded_userinfo/1, parse_port/1, + parse_query/1, parse_scheme/1, parse_userinfo/1, + parse_list/1, parse_binary/1, parse_mixed/1, parse_relative/1, + parse_special/1, parse_special2/1, parse_negative/1, + recompose_fragment/1, recompose_parse_fragment/1, + recompose_query/1, recompose_parse_query/1, + recompose_path/1, recompose_parse_path/1, + recompose_autogen/1, parse_recompose_autogen/1, + transcode_basic/1, transcode_options/1, transcode_mixed/1, transcode_negative/1, + compose_query/1, compose_query_latin1/1, compose_query_negative/1, + dissect_query/1, dissect_query_negative/1, + interop_query_latin1/1, interop_query_utf8/1 + ]). + + +-define(SCHEME, "foo"). +-define(USERINFO, "åsa"). +-define(USERINFO_ENC, "%C3%A5sa"). +-define(HOST, "älvsjö"). +-define(HOST_ENC, "%C3%A4lvsj%C3%B6"). +-define(IPV6, "::127.0.0.1"). +-define(IPV6_ENC, "[::127.0.0.1]"). +-define(PORT, 8042). +-define(PORT_ENC, ":8042"). +-define(PATH, "/där"). +-define(PATH_ENC, "/d%C3%A4r"). +-define(QUERY, "name=örn"). +-define(QUERY_ENC, "?name=%C3%B6rn"). +-define(FRAGMENT, "näsa"). +-define(FRAGMENT_ENC, "#n%C3%A4sa"). + + +suite() -> + [{timetrap,{minutes,1}}]. + +all() -> + [ + normalize, + parse_binary_scheme, + parse_binary_userinfo, + parse_binary_pct_encoded_userinfo, + parse_binary_host, + parse_binary_host_ipv4, + parse_binary_host_ipv6, + parse_binary_port, + parse_binary_path, + parse_binary_query, + parse_binary_pct_encoded_query, + parse_binary_fragment, + parse_binary_pct_encoded_fragment, + parse_scheme, + parse_userinfo, + parse_pct_encoded_userinfo, + parse_host, + parse_host_ipv4, + parse_host_ipv6, + parse_port, + parse_path, + parse_query, + parse_pct_encoded_query, + parse_fragment, + parse_pct_encoded_fragment, + parse_list, + parse_binary, + parse_mixed, + parse_relative, + parse_special, + parse_special2, + parse_negative, + recompose_fragment, + recompose_parse_fragment, + recompose_query, + recompose_parse_query, + recompose_path, + recompose_parse_path, + recompose_autogen, + parse_recompose_autogen, + transcode_basic, + transcode_options, + transcode_mixed, + transcode_negative, + compose_query, + compose_query_latin1, + compose_query_negative, + dissect_query, + dissect_query_negative, + interop_query_latin1, + interop_query_utf8 + ]. + +groups() -> + []. + + +%%------------------------------------------------------------------------- +%% Helper functions +%%------------------------------------------------------------------------- +uri_combinations() -> + [[Sch,Usr,Hst,Prt,Pat,Qry,Frg] || + Sch <- [fun update_scheme/1, fun update_scheme_binary/1, none], + Usr <- [fun update_userinfo/1, fun update_userinfo_binary/1, none], + Hst <- [fun update_host/1, fun update_host_binary/1, + fun update_ipv6/1, fun update_ipv6_binary/1, none], + Prt <- [fun update_port/1, none], + Pat <- [fun update_path/1, fun update_path_binary/1], + Qry <- [fun update_query/1,fun update_query_binary/1, none], + Frg <- [fun update_fragment/1, fun update_fragment_binary/1, none], + not (Usr =:= none andalso Hst =:= none andalso Prt =/= none), + not (Usr =/= none andalso Hst =:= none andalso Prt =:= none), + not (Usr =/= none andalso Hst =:= none andalso Prt =/= none)]. + + +generate_test_vector(Comb) -> + Fun = fun (F, {Map, URI}) when is_function(F) -> F({Map, URI}); + (_, Map) -> Map + end, + lists:foldl(Fun, {#{}, empty}, Comb). + +generate_test_vectors(L) -> + lists:map(fun generate_test_vector/1, L). + +update_fragment({In, empty}) -> + {In#{fragment => ?FRAGMENT}, ?FRAGMENT_ENC}; +update_fragment({In, Out}) when is_list(Out) -> + {In#{fragment => ?FRAGMENT}, Out ++ ?FRAGMENT_ENC}; +update_fragment({In, Out}) when is_binary(Out) -> + {In#{fragment => ?FRAGMENT}, binary_to_list(Out) ++ ?FRAGMENT_ENC}. + +update_fragment_binary({In, empty}) -> + {In#{fragment => <<?FRAGMENT/utf8>>}, <<?FRAGMENT_ENC>>}; +update_fragment_binary({In, Out}) when is_list(Out) -> + {In#{fragment => <<?FRAGMENT/utf8>>}, Out ++ ?FRAGMENT_ENC}; +update_fragment_binary({In, Out}) when is_binary(Out) -> + {In#{fragment => <<?FRAGMENT/utf8>>}, <<Out/binary,?FRAGMENT_ENC>>}. + + +update_query({In, empty}) -> + {In#{query => ?QUERY}, ?QUERY_ENC}; +update_query({In, Out}) when is_list(Out) -> + {In#{query => ?QUERY}, Out ++ ?QUERY_ENC}; +update_query({In, Out}) when is_binary(Out) -> + {In#{query => ?QUERY}, binary_to_list(Out) ++ ?QUERY_ENC}. + +update_query_binary({In, empty}) -> + {In#{query => <<?QUERY/utf8>>}, <<?QUERY_ENC>>}; +update_query_binary({In, Out}) when is_list(Out) -> + {In#{query => <<?QUERY/utf8>>}, Out ++ ?QUERY_ENC}; +update_query_binary({In, Out}) when is_binary(Out) -> + {In#{query => <<?QUERY/utf8>>}, <<Out/binary,?QUERY_ENC>>}. + +update_path({In, empty}) -> + {In#{path => ?PATH}, ?PATH_ENC}; +update_path({In, Out}) when is_list(Out) -> + {In#{path => ?PATH}, Out ++ ?PATH_ENC}; +update_path({In, Out}) when is_binary(Out) -> + {In#{path => ?PATH}, binary_to_list(Out) ++ ?PATH_ENC}. + +update_path_binary({In, empty}) -> + {In#{path => <<?PATH/utf8>>}, <<?PATH_ENC>>}; +update_path_binary({In, Out}) when is_list(Out) -> + {In#{path => <<?PATH/utf8>>}, Out ++ ?PATH_ENC}; +update_path_binary({In, Out}) when is_binary(Out) -> + {In#{path => <<?PATH/utf8>>}, <<Out/binary,?PATH_ENC>>}. + +update_port({In, Out}) when is_list(Out) -> + {In#{port => ?PORT}, Out ++ ?PORT_ENC}; +update_port({In, Out}) when is_binary(Out) -> + {In#{port => ?PORT}, <<Out/binary,?PORT_ENC>>}. + +update_host({In, empty}) -> + {In#{host => ?HOST}, "//" ++ ?HOST_ENC}; +update_host({In, Out}) when is_list(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => ?HOST}, Out ++ [$@|?HOST_ENC]}; + false -> {In#{host => ?HOST}, Out ++ [$/,$/|?HOST_ENC]} + end; +update_host({In, Out}) when is_binary(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => ?HOST}, binary_to_list(Out) ++ [$@|?HOST_ENC]}; + false -> {In#{host => ?HOST}, binary_to_list(Out) ++ [$/,$/|?HOST_ENC]} + end. + +update_host_binary({In, empty}) -> + {In#{host => <<?HOST/utf8>>}, <<"//",?HOST_ENC>>}; +update_host_binary({In, Out}) when is_list(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => <<?HOST/utf8>>}, Out ++ [$@|?HOST_ENC]}; + false -> {In#{host => <<?HOST/utf8>>}, Out ++ [$/,$/|?HOST_ENC]} + end; +update_host_binary({In, Out}) when is_binary(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => <<?HOST/utf8>>}, <<Out/binary,$@,?HOST_ENC>>}; + false-> {In#{host => <<?HOST/utf8>>}, <<Out/binary,"//",?HOST_ENC>>} + end. + +update_ipv6({In, empty}) -> + {In#{host => ?IPV6}, "//" ++ ?IPV6_ENC}; +update_ipv6({In, Out}) when is_list(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => ?IPV6}, Out ++ [$@|?IPV6_ENC]}; + false -> {In#{host => ?IPV6}, Out ++ [$/,$/|?IPV6_ENC]} + end; +update_ipv6({In, Out}) when is_binary(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => ?IPV6}, binary_to_list(Out) ++ [$@|?IPV6_ENC]}; + false -> {In#{host => ?IPV6}, binary_to_list(Out) ++ [$/,$/|?IPV6_ENC]} + end. + +update_ipv6_binary({In, empty}) -> + {In#{host => <<?IPV6/utf8>>}, <<"//",?IPV6_ENC>>}; +update_ipv6_binary({In, Out}) when is_list(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => <<?IPV6/utf8>>}, Out ++ [$@|?IPV6_ENC]}; + false -> {In#{host => <<?IPV6/utf8>>}, Out ++ [$/,$/|?IPV6_ENC]} + end; +update_ipv6_binary({In, Out}) when is_binary(Out) -> + case maps:is_key(userinfo, In) of + true -> {In#{host => <<?IPV6/utf8>>}, <<Out/binary,$@,?IPV6_ENC>>}; + false-> {In#{host => <<?IPV6/utf8>>}, <<Out/binary,"//",?IPV6_ENC>>} + end. + +update_userinfo({In, empty}) -> + {In#{userinfo => ?USERINFO}, "//" ++ ?USERINFO_ENC}; +update_userinfo({In, Out}) when is_list(Out) -> + {In#{userinfo => ?USERINFO}, Out ++ "//" ++ ?USERINFO_ENC}; +update_userinfo({In, Out}) when is_binary(Out) -> + {In#{userinfo => ?USERINFO}, binary_to_list(Out) ++ "//" ++ ?USERINFO_ENC}. + +update_userinfo_binary({In, empty}) -> + {In#{userinfo => <<?USERINFO/utf8>>}, <<"//",?USERINFO_ENC>>}; +update_userinfo_binary({In, Out}) when is_list(Out) -> + {In#{userinfo => <<?USERINFO/utf8>>}, Out ++ "//" ++ ?USERINFO_ENC}; +update_userinfo_binary({In, Out}) when is_binary(Out) -> + {In#{userinfo => <<?USERINFO/utf8>>}, <<Out/binary,"//",?USERINFO_ENC>>}. + +update_scheme({In, empty}) -> + {In#{scheme => ?SCHEME}, ?SCHEME ++ ":"}. + +update_scheme_binary({In, empty}) -> + {In#{scheme => <<?SCHEME/utf8>>}, <<?SCHEME,$:>>}. + + +%% Test recompose on a generated test vector +run_test_recompose({#{}, empty}) -> + try "" = uri_string:recompose(#{}) of + _ -> ok + catch + _:_ -> error({test_failed, #{}, ""}) + end; +run_test_recompose({Map, URI}) -> + try URI = uri_string:recompose(Map) of + URI -> ok + catch + _:_ -> error({test_failed, Map, URI}) + end. + +%% Test parse - recompose on a generated test vector +run_test_parse_recompose({#{}, empty}) -> + try "" = uri_string:recompose(uri_string:parse("")) of + _ -> ok + catch + _:_ -> error({test_failed, #{}, ""}) + end; +run_test_parse_recompose({Map, URI}) -> + try URI = uri_string:recompose(uri_string:parse(URI)) of + URI -> ok + catch + _:_ -> error({test_failed, Map, URI}) + end. + + +%%------------------------------------------------------------------------- +%% Parse tests +%%------------------------------------------------------------------------- + +parse_binary_scheme(_Config) -> + #{} = uri_string:parse(<<>>), + #{path := <<"foo">>} = uri_string:parse(<<"foo">>), + #{scheme := <<"foo">>} = uri_string:parse(<<"foo:">>), + #{scheme := <<"foo">>, path := <<"bar:nisse">>} = uri_string:parse(<<"foo:bar:nisse">>), + #{scheme := <<"foo">>, host := <<"">>} = uri_string:parse(<<"foo://">>), + #{scheme := <<"foo">>, host := <<"">>, path := <<"/">>} = uri_string:parse(<<"foo:///">>), + #{scheme := <<"foo">>, host := <<"">>, path := <<"//">>} = uri_string:parse(<<"foo:////">>), + + #{path := <<"/">>} = uri_string:parse(<<"/">>), + #{host := <<>>} = uri_string:parse(<<"//">>), + #{host := <<>>, path := <<"/">>} = uri_string:parse(<<"///">>). + +parse_binary_userinfo(_Config) -> + #{scheme := <<"user">>, path := <<"password@localhost">>} = + uri_string:parse(<<"user:password@localhost">>), + #{path := <<"user@">>} = uri_string:parse(<<"user@">>), + #{path := <<"/user@">>} = uri_string:parse(<<"/user@">>), + #{path := <<"user@localhost">>} = uri_string:parse(<<"user@localhost">>), + #{userinfo := <<"user">>, host := <<"localhost">>} = uri_string:parse(<<"//user@localhost">>), + #{userinfo := <<"user:password">>, host := <<"localhost">>} = + uri_string:parse(<<"//user:password@localhost">>), + #{scheme := <<"foo">>, path := <<"/user@">>} = + uri_string:parse(<<"foo:/user@">>), + #{scheme := <<"foo">>, userinfo := <<"user">>, host := <<"localhost">>} = + uri_string:parse(<<"foo://user@localhost">>), + #{scheme := <<"foo">>, userinfo := <<"user:password">>, host := <<"localhost">>} = + uri_string:parse(<<"foo://user:password@localhost">>). + +parse_binary_pct_encoded_userinfo(_Config) -> + #{scheme := <<"user">>, path := <<"合@気道"/utf8>>} = + uri_string:parse(<<"user:%E5%90%88@%E6%B0%97%E9%81%93">>), + #{path := <<"合気道@"/utf8>>} = uri_string:parse(<<"%E5%90%88%E6%B0%97%E9%81%93@">>), + #{path := <<"/合気道@"/utf8>>} = uri_string:parse(<<"/%E5%90%88%E6%B0%97%E9%81%93@">>), + #{path := <<"合@気道"/utf8>>} = uri_string:parse(<<"%E5%90%88@%E6%B0%97%E9%81%93">>), + #{userinfo := <<"合"/utf8>>, host := <<"気道"/utf8>>} = + uri_string:parse(<<"//%E5%90%88@%E6%B0%97%E9%81%93">>), + #{userinfo := <<"合:気"/utf8>>, host := <<"道"/utf8>>} = + uri_string:parse(<<"//%E5%90%88:%E6%B0%97@%E9%81%93">>), + #{scheme := <<"foo">>, path := <<"/合気道@"/utf8>>} = + uri_string:parse(<<"foo:/%E5%90%88%E6%B0%97%E9%81%93@">>), + #{scheme := <<"foo">>, userinfo := <<"合"/utf8>>, host := <<"気道"/utf8>>} = + uri_string:parse(<<"foo://%E5%90%88@%E6%B0%97%E9%81%93">>), + #{scheme := <<"foo">>, userinfo := <<"合:気"/utf8>>, host := <<"道"/utf8>>} = + uri_string:parse(<<"foo://%E5%90%88:%E6%B0%97@%E9%81%93">>), + {error,invalid_uri,"@"} = uri_string:parse(<<"//%E5%90%88@%E6%B0%97%E9%81%93@">>), + {error,invalid_uri,":"} = uri_string:parse(<<"foo://%E5%90%88@%E6%B0%97%E9%81%93@">>). + +parse_binary_host(_Config) -> + #{host := <<"hostname">>} = uri_string:parse(<<"//hostname">>), + #{host := <<"hostname">>,scheme := <<"foo">>} = uri_string:parse(<<"foo://hostname">>), + #{host := <<"hostname">>,scheme := <<"foo">>, userinfo := <<"user">>} = + uri_string:parse(<<"foo://user@hostname">>). + +parse_binary_host_ipv4(_Config) -> + #{host := <<"127.0.0.1">>} = uri_string:parse(<<"//127.0.0.1">>), + #{host := <<"127.0.0.1">>, path := <<"/over/there">>} = + uri_string:parse(<<"//127.0.0.1/over/there">>), + #{host := <<"127.0.0.1">>, query := <<"name=ferret">>} = + uri_string:parse(<<"//127.0.0.1?name=ferret">>), + #{host := <<"127.0.0.1">>, fragment := <<"nose">>} = uri_string:parse(<<"//127.0.0.1#nose">>), + {error,invalid_uri,"x"} = uri_string:parse(<<"//127.0.0.x">>), + {error,invalid_uri,"1227.0.0.1"} = uri_string:parse(<<"//1227.0.0.1">>). + +parse_binary_host_ipv6(_Config) -> + #{host := <<"::127.0.0.1">>} = uri_string:parse(<<"//[::127.0.0.1]">>), + #{host := <<"2001:0db8:0000:0000:0000:0000:1428:07ab">>} = + uri_string:parse(<<"//[2001:0db8:0000:0000:0000:0000:1428:07ab]">>), + #{host := <<"::127.0.0.1">>, path := <<"/over/there">>} = + uri_string:parse(<<"//[::127.0.0.1]/over/there">>), + #{host := <<"::127.0.0.1">>, query := <<"name=ferret">>} = + uri_string:parse(<<"//[::127.0.0.1]?name=ferret">>), + #{host := <<"::127.0.0.1">>, fragment := <<"nose">>} = + uri_string:parse(<<"//[::127.0.0.1]#nose">>), + {error,invalid_uri,"x"} = uri_string:parse(<<"//[::127.0.0.x]">>), + {error,invalid_uri,"::1227.0.0.1"} = uri_string:parse(<<"//[::1227.0.0.1]">>), + {error,invalid_uri,"G"} = uri_string:parse(<<"//[2001:0db8:0000:0000:0000:0000:1428:G7ab]">>). + +parse_binary_port(_Config) -> + #{path:= <<"/:8042">>} = + uri_string:parse(<<"/:8042">>), + #{host:= <<>>, port := 8042} = + uri_string:parse(<<"//:8042">>), + #{host := <<"example.com">>, port:= 8042} = + uri_string:parse(<<"//example.com:8042">>), + #{scheme := <<"foo">>, path := <<"/:8042">>} = + uri_string:parse(<<"foo:/:8042">>), + #{scheme := <<"foo">>, host := <<>>, port := 8042} = + uri_string:parse(<<"foo://:8042">>), + #{scheme := <<"foo">>, host := <<"example.com">>, port := 8042} = + uri_string:parse(<<"foo://example.com:8042">>), + {error,invalid_uri,":"} = uri_string:parse(":600"), + {error,invalid_uri,"x"} = uri_string:parse("//:8042x"). + +parse_binary_path(_Config) -> + #{path := <<"over/there">>} = uri_string:parse(<<"over/there">>), + #{path := <<"/over/there">>} = uri_string:parse(<<"/over/there">>), + #{scheme := <<"foo">>, path := <<"/over/there">>} = + uri_string:parse(<<"foo:/over/there">>), + #{scheme := <<"foo">>, host := <<"example.com">>, path := <<"/over/there">>} = + uri_string:parse(<<"foo://example.com/over/there">>), + #{scheme := <<"foo">>, host := <<"example.com">>, path := <<"/over/there">>, port := 8042} = + uri_string:parse(<<"foo://example.com:8042/over/there">>). + +parse_binary_query(_Config) -> + #{scheme := <<"foo">>, query := <<"name=ferret">>} = + uri_string:parse(<<"foo:?name=ferret">>), + #{scheme := <<"foo">>, path:= <<"over/there">>, query := <<"name=ferret">>} = + uri_string:parse(<<"foo:over/there?name=ferret">>), + #{scheme := <<"foo">>, path:= <<"/over/there">>, query := <<"name=ferret">>} = + uri_string:parse(<<"foo:/over/there?name=ferret">>), + #{scheme := <<"foo">>, host := <<"example.com">>, query := <<"name=ferret">>} = + uri_string:parse(<<"foo://example.com?name=ferret">>), + #{scheme := <<"foo">>, host := <<"example.com">>, path := <<"/">>, query := <<"name=ferret">>} = + uri_string:parse(<<"foo://example.com/?name=ferret">>), + + #{path := <<>>, query := <<"name=ferret">>} = + uri_string:parse(<<"?name=ferret">>), + #{path := <<"over/there">>, query := <<"name=ferret">>} = + uri_string:parse(<<"over/there?name=ferret">>), + #{path := <<"/">>, query := <<"name=ferret">>} = + uri_string:parse(<<"/?name=ferret">>), + #{path := <<"/over/there">>, query := <<"name=ferret">>} = + uri_string:parse(<<"/over/there?name=ferret">>), + #{host := <<"example.com">>, query := <<"name=ferret">>} = + uri_string:parse(<<"//example.com?name=ferret">>), + #{host := <<"example.com">>, path := <<"/">>, query := <<"name=ferret">>} = + uri_string:parse(<<"//example.com/?name=ferret">>). + +parse_binary_pct_encoded_query(_Config) -> + #{scheme := <<"foo">>, host := <<"example.com">>, path := <<"/">>, + query := <<"name=合気道"/utf8>>} = + uri_string:parse(<<"foo://example.com/?name=%E5%90%88%E6%B0%97%E9%81%93">>), + #{host := <<"example.com">>, path := <<"/">>, query := <<"name=合気道"/utf8>>} = + uri_string:parse(<<"//example.com/?name=%E5%90%88%E6%B0%97%E9%81%93">>). + +parse_binary_fragment(_Config) -> + #{scheme := <<"foo">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo:#nose">>), + #{scheme := <<"foo">>, path:= <<"over/there">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo:over/there#nose">>), + #{scheme := <<"foo">>, path:= <<"/over/there">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo:/over/there#nose">>), + #{scheme := <<"foo">>, host := <<"example.com">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo://example.com#nose">>), + #{scheme := <<"foo">>, host := <<"example.com">>, path := <<"/">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo://example.com/#nose">>), + #{scheme := <<"foo">>, host := <<"example.com">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo://example.com#nose">>), + + #{fragment := <<"nose">>} = + uri_string:parse(<<"#nose">>), + #{path := <<"over/there">>, fragment := <<"nose">>} = + uri_string:parse(<<"over/there#nose">>), + #{path := <<"/">>, fragment := <<"nose">>} = + uri_string:parse(<<"/#nose">>), + #{path := <<"/over/there">>, fragment := <<"nose">>} = + uri_string:parse(<<"/over/there#nose">>), + #{host := <<"example.com">>, fragment := <<"nose">>} = + uri_string:parse(<<"//example.com#nose">>), + #{host := <<"example.com">>, path := <<"/">>, fragment := <<"nose">>} = + uri_string:parse(<<"//example.com/#nose">>). + +parse_binary_pct_encoded_fragment(_Config) -> + #{scheme := <<"foo">>, host := <<"example.com">>, fragment := <<"合気道"/utf8>>} = + uri_string:parse(<<"foo://example.com#%E5%90%88%E6%B0%97%E9%81%93">>), + #{host := <<"example.com">>, path := <<"/">>, fragment := <<"合気道"/utf8>>} = + uri_string:parse(<<"//example.com/#%E5%90%88%E6%B0%97%E9%81%93">>). + +parse_scheme(_Config) -> + #{} = uri_string:parse(""), + #{path := "foo"} = uri_string:parse("foo"), + #{scheme := "foo"} = uri_string:parse("foo:"), + #{scheme := "foo", path := "bar:nisse"} = uri_string:parse("foo:bar:nisse"), + #{scheme := "foo", host := ""} = uri_string:parse("foo://"), + #{scheme := "foo", host := "", path := "/"} = uri_string:parse("foo:///"), + #{scheme := "foo", host := "", path := "//"} = uri_string:parse("foo:////"), + + #{path := "/"} = uri_string:parse("/"), + #{host := ""} = uri_string:parse("//"), + #{host := "", path := "/"} = uri_string:parse("///"). + +parse_userinfo(_Config) -> + #{scheme := "user", path := "password@localhost"} = uri_string:parse("user:password@localhost"), + #{path := "user@"} = uri_string:parse("user@"), + #{path := "/user@"} = uri_string:parse("/user@"), + #{path := "user@localhost"} = uri_string:parse("user@localhost"), + #{userinfo := "user", host := "localhost"} = uri_string:parse("//user@localhost"), + #{userinfo := "user:password", host := "localhost"} = + uri_string:parse("//user:password@localhost"), + #{scheme := "foo", path := "/user@"} = + uri_string:parse("foo:/user@"), + #{scheme := "foo", userinfo := "user", host := "localhost"} = + uri_string:parse("foo://user@localhost"), + #{scheme := "foo", userinfo := "user:password", host := "localhost"} = + uri_string:parse("foo://user:password@localhost"). + +parse_pct_encoded_userinfo(_Config) -> + #{scheme := "user", path := "合@気道"} = + uri_string:parse("user:%E5%90%88@%E6%B0%97%E9%81%93"), + #{path := "合気道@"} = uri_string:parse("%E5%90%88%E6%B0%97%E9%81%93@"), + #{path := "/合気道@"} = uri_string:parse("/%E5%90%88%E6%B0%97%E9%81%93@"), + #{path := "合@気道"} = uri_string:parse("%E5%90%88@%E6%B0%97%E9%81%93"), + #{userinfo := "合", host := "気道"} = + uri_string:parse("//%E5%90%88@%E6%B0%97%E9%81%93"), + #{userinfo := "合:気", host := "道"} = + uri_string:parse("//%E5%90%88:%E6%B0%97@%E9%81%93"), + #{scheme := "foo", path := "/合気道@"} = + uri_string:parse("foo:/%E5%90%88%E6%B0%97%E9%81%93@"), + #{scheme := "foo", userinfo := "合", host := "気道"} = + uri_string:parse("foo://%E5%90%88@%E6%B0%97%E9%81%93"), + #{scheme := "foo", userinfo := "合:気", host := "道"} = + uri_string:parse("foo://%E5%90%88:%E6%B0%97@%E9%81%93"), + {error,invalid_uri,"@"} = uri_string:parse("//%E5%90%88@%E6%B0%97%E9%81%93@"), + {error,invalid_uri,":"} = uri_string:parse("foo://%E5%90%88@%E6%B0%97%E9%81%93@"). + + +parse_host(_Config) -> + #{host := "hostname"} = uri_string:parse("//hostname"), + #{host := "hostname",scheme := "foo"} = uri_string:parse("foo://hostname"), + #{host := "hostname",scheme := "foo", userinfo := "user"} = + uri_string:parse("foo://user@hostname"). + +parse_host_ipv4(_Config) -> + #{host := "127.0.0.1"} = uri_string:parse("//127.0.0.1"), + #{host := "2001:0db8:0000:0000:0000:0000:1428:07ab"} = + uri_string:parse("//[2001:0db8:0000:0000:0000:0000:1428:07ab]"), + #{host := "127.0.0.1", path := "/over/there"} = uri_string:parse("//127.0.0.1/over/there"), + #{host := "127.0.0.1", query := "name=ferret"} = uri_string:parse("//127.0.0.1?name=ferret"), + #{host := "127.0.0.1", fragment := "nose"} = uri_string:parse("//127.0.0.1#nose"), + {error,invalid_uri,"x"} = uri_string:parse("//127.0.0.x"), + {error,invalid_uri,"1227.0.0.1"} = uri_string:parse("//1227.0.0.1"). + +parse_host_ipv6(_Config) -> + #{host := "::127.0.0.1"} = uri_string:parse("//[::127.0.0.1]"), + #{host := "::127.0.0.1", path := "/over/there"} = uri_string:parse("//[::127.0.0.1]/over/there"), + #{host := "::127.0.0.1", query := "name=ferret"} = + uri_string:parse("//[::127.0.0.1]?name=ferret"), + #{host := "::127.0.0.1", fragment := "nose"} = uri_string:parse("//[::127.0.0.1]#nose"), + {error,invalid_uri,"x"} = uri_string:parse("//[::127.0.0.x]"), + {error,invalid_uri,"::1227.0.0.1"} = uri_string:parse("//[::1227.0.0.1]"), + {error,invalid_uri,"G"} = uri_string:parse("//[2001:0db8:0000:0000:0000:0000:1428:G7ab]"). + +parse_port(_Config) -> + #{path:= "/:8042"} = + uri_string:parse("/:8042"), + #{host:= "", port := 8042} = + uri_string:parse("//:8042"), + #{host := "example.com", port:= 8042} = + uri_string:parse("//example.com:8042"), + #{scheme := "foo", path := "/:8042"} = + uri_string:parse("foo:/:8042"), + #{scheme := "foo", host := "", port := 8042} = + uri_string:parse("foo://:8042"), + #{scheme := "foo", host := "example.com", port := 8042} = + uri_string:parse("foo://example.com:8042"). + +parse_path(_Config) -> + #{path := "over/there"} = uri_string:parse("over/there"), + #{path := "/over/there"} = uri_string:parse("/over/there"), + #{scheme := "foo", path := "/over/there"} = + uri_string:parse("foo:/over/there"), + #{scheme := "foo", host := "example.com", path := "/over/there"} = + uri_string:parse("foo://example.com/over/there"), + #{scheme := "foo", host := "example.com", path := "/over/there", port := 8042} = + uri_string:parse("foo://example.com:8042/over/there"). + +parse_query(_Config) -> + #{scheme := "foo", query := "name=ferret"} = + uri_string:parse("foo:?name=ferret"), + #{scheme := "foo", path:= "over/there", query := "name=ferret"} = + uri_string:parse("foo:over/there?name=ferret"), + #{scheme := "foo", path:= "/over/there", query := "name=ferret"} = + uri_string:parse("foo:/over/there?name=ferret"), + #{scheme := "foo", host := "example.com", query := "name=ferret"} = + uri_string:parse("foo://example.com?name=ferret"), + #{scheme := "foo", host := "example.com", path := "/", query := "name=ferret"} = + uri_string:parse("foo://example.com/?name=ferret"), + + #{path := "", query := "name=ferret"} = + uri_string:parse("?name=ferret"), + #{path := "over/there", query := "name=ferret"} = + uri_string:parse("over/there?name=ferret"), + #{path := "/", query := "name=ferret"} = + uri_string:parse("/?name=ferret"), + #{path := "/over/there", query := "name=ferret"} = + uri_string:parse("/over/there?name=ferret"), + #{host := "example.com", query := "name=ferret"} = + uri_string:parse("//example.com?name=ferret"), + #{host := "example.com", path := "/", query := "name=ferret"} = + uri_string:parse("//example.com/?name=ferret"). + +parse_pct_encoded_query(_Config) -> + #{scheme := "foo", host := "example.com", path := "/", + query := "name=合気道"} = + uri_string:parse("foo://example.com/?name=%E5%90%88%E6%B0%97%E9%81%93"), + #{host := "example.com", path := "/", query := "name=合気道"} = + uri_string:parse("//example.com/?name=%E5%90%88%E6%B0%97%E9%81%93"). + +parse_fragment(_Config) -> + #{scheme := "foo", fragment := "nose"} = + uri_string:parse("foo:#nose"), + #{scheme := "foo", path:= "over/there", fragment := "nose"} = + uri_string:parse("foo:over/there#nose"), + #{scheme := "foo", path:= "/over/there", fragment := "nose"} = + uri_string:parse("foo:/over/there#nose"), + #{scheme := "foo", host := "example.com", fragment := "nose"} = + uri_string:parse("foo://example.com#nose"), + #{scheme := "foo", host := "example.com", path := "/", fragment := "nose"} = + uri_string:parse("foo://example.com/#nose"), + #{scheme := "foo", host := "example.com", fragment := "nose"} = + uri_string:parse("foo://example.com#nose"), + + #{fragment := "nose"} = + uri_string:parse("#nose"), + #{path := "over/there", fragment := "nose"} = + uri_string:parse("over/there#nose"), + #{path := "/", fragment := "nose"} = + uri_string:parse("/#nose"), + #{path := "/over/there", fragment := "nose"} = + uri_string:parse("/over/there#nose"), + #{host := "example.com", fragment := "nose"} = + uri_string:parse("//example.com#nose"), + #{host := "example.com", path := "/", fragment := "nose"} = + uri_string:parse("//example.com/#nose"). + +parse_pct_encoded_fragment(_Config) -> + #{scheme := "foo", host := "example.com", fragment := "合気道"} = + uri_string:parse("foo://example.com#%E5%90%88%E6%B0%97%E9%81%93"), + #{host := "example.com", path := "/", fragment := "合気道"} = + uri_string:parse("//example.com/#%E5%90%88%E6%B0%97%E9%81%93"). + +parse_list(_Config) -> + #{scheme := "foo", path := "bar:nisse"} = uri_string:parse("foo:bar:nisse"), + #{scheme := "foo", host := "example.com", port := 8042, + path := "/over/there", query := "name=ferret", fragment := "nose"} = + uri_string:parse("foo://example.com:8042/over/there?name=ferret#nose"), + #{scheme := "foo", userinfo := "admin:admin", host := "example.com", port := 8042, + path := "/over/there", query := "name=ferret", fragment := "nose"} = + uri_string:parse("foo://admin:[email protected]:8042/over/there?name=ferret#nose"). + +parse_binary(_Config) -> + #{scheme := <<"foo">>, path := <<"bar:nisse">>} = uri_string:parse(<<"foo:bar:nisse">>), + #{scheme := <<"foo">>, host := <<"example.com">>, port := 8042, + path := <<"/over/there">>, query := <<"name=ferret">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo://example.com:8042/over/there?name=ferret#nose">>), + #{scheme := <<"foo">>, userinfo := <<"admin:admin">>, host := <<"example.com">>, port := 8042, + path := <<"/over/there">>, query := <<"name=ferret">>, fragment := <<"nose">>} = + uri_string:parse(<<"foo://admin:[email protected]:8042/over/there?name=ferret#nose">>). + + +parse_mixed(_Config) -> + #{scheme := "foo", path := "bar"} = + uri_string:parse(lists:append("fo",<<"o:bar">>)), + #{scheme := "foo", path := "bar"} = + uri_string:parse(lists:append("foo:b",<<"ar">>)), + #{scheme := "foo", path := "bar:bar"} = + uri_string:parse([[102],[111,111],<<":bar">>,58,98,97,114]). + +parse_relative(_Config) -> + #{path := "/path"} = + uri_string:parse(lists:append("/pa",<<"th">>)), + #{path := "foo"} = + uri_string:parse(lists:append("fo",<<"o">>)). + +parse_special(_Config) -> + #{host := [],query := []} = uri_string:parse("//?"), + #{fragment := [],host := []} = uri_string:parse("//#"), + #{host := [],query := [],scheme := "foo"} = uri_string:parse("foo://?"), + #{fragment := [],host := [],scheme := "foo"} = uri_string:parse("foo://#"), + #{host := <<>>, path := <<"/">>} = uri_string:parse(<<"///">>), + #{host := <<"hostname">>} = uri_string:parse(<<"//hostname">>), + #{host := <<>>, path := <<"/hostname">>} = uri_string:parse(<<"///hostname">>), + #{host := [],path := "/",query := []} = uri_string:parse("///?"), + #{fragment := [],host := [],path := "/"} = uri_string:parse("///#"), + #{host := "foo",query := []} = uri_string:parse("//foo?"), + #{fragment := [],host := "foo"} = uri_string:parse("//foo#"), + #{host := "foo",path := "/"} = uri_string:parse("//foo/"), + #{host := "foo",query := [],scheme := "http"} = uri_string:parse("http://foo?"), + #{fragment := [],host := "foo",scheme := "http"} = uri_string:parse("http://foo#"), + #{host := "foo",path := "/",scheme := "http"} = uri_string:parse("http://foo/"), + #{fragment := [],host := "host",port := 80,scheme := "http"} = uri_string:parse("http://host:80#"), + #{host := "host",port := 80,query := [],scheme := "http"} = uri_string:parse("http://host:80?"), + #{path := [],query := []} = uri_string:parse("?"), + #{path := [],query := "?"} = uri_string:parse("??"), + #{path := [],query := "??"} = uri_string:parse("???"). + +parse_special2(_Config) -> + #{host := [],path := "/",port := 1,scheme := "a"} = uri_string:parse("a://:1/"), + #{path := "/a/",scheme := "a"} = uri_string:parse("a:/a/"), + #{host := [],path := [],userinfo := []} = uri_string:parse("//@"), + #{host := [],path := [],scheme := "foo",userinfo := []} = uri_string:parse("foo://@"), + #{host := [],path := "/",userinfo := []} = uri_string:parse("//@/"), + #{host := [],path := "/",scheme := "foo",userinfo := []} = uri_string:parse("foo://@/"), + #{host := "localhost",path := "/",port := undefined} = uri_string:parse("//localhost:/"), + #{host := [],path := [],port := undefined} = uri_string:parse("//:"). + +parse_negative(_Config) -> + {error,invalid_uri,"å"} = uri_string:parse("å"), + {error,invalid_uri,"å"} = uri_string:parse("aå:/foo"), + {error,invalid_uri,":"} = uri_string:parse("foo://usär@host"), + {error,invalid_uri,"ö"} = uri_string:parse("//host/path?foö=bar"), + {error,invalid_uri,"ö"} = uri_string:parse("//host/path#foö"), + {error,invalid_uri,"127.256.0.1"} = uri_string:parse("//127.256.0.1"), + {error,invalid_uri,":::127.0.0.1"} = uri_string:parse("//[:::127.0.0.1]"), + {error,invalid_utf8,<<0,0,0,246>>} = uri_string:parse("//%00%00%00%F6"), + {error,invalid_uri,"A"} = uri_string:parse("//localhost:A8"). + + +%%------------------------------------------------------------------------- +%% Recompose tests +%%------------------------------------------------------------------------- +recompose_fragment(_Config) -> + <<?FRAGMENT_ENC>> = uri_string:recompose(#{fragment => <<?FRAGMENT/utf8>>, path => <<>>}), + ?FRAGMENT_ENC = uri_string:recompose(#{fragment => ?FRAGMENT, path => ""}). + +recompose_parse_fragment(_Config) -> + <<?FRAGMENT_ENC>> = uri_string:recompose(uri_string:parse(<<?FRAGMENT_ENC>>)), + ?FRAGMENT_ENC = uri_string:recompose(uri_string:parse(?FRAGMENT_ENC)). + +recompose_query(_Config) -> + <<?QUERY_ENC>> = + uri_string:recompose(#{query => <<?QUERY/utf8>>, path => <<>>}), + <<?QUERY_ENC?FRAGMENT_ENC>> = + uri_string:recompose(#{query => <<?QUERY/utf8>>, + fragment => <<?FRAGMENT/utf8>>, + path => <<>>}), + "?name=%C3%B6rn" = + uri_string:recompose(#{query => "name=örn", path => ""}), + "?name=%C3%B6rn#n%C3%A4sa" = + uri_string:recompose(#{query => "name=örn", + fragment => "näsa", + path => ""}). + +recompose_parse_query(_Config) -> + <<"?name=%C3%B6rn">> = uri_string:recompose(uri_string:parse(<<"?name=%C3%B6rn">>)), + <<"?name=%C3%B6rn#n%C3%A4sa">> = + uri_string:recompose(uri_string:parse(<<"?name=%C3%B6rn#n%C3%A4sa">>)), + "?name=%C3%B6rn" = uri_string:recompose(uri_string:parse("?name=%C3%B6rn")), + "?name=%C3%B6rn#n%C3%A4sa" = uri_string:recompose(uri_string:parse("?name=%C3%B6rn#n%C3%A4sa")). + +recompose_path(_Config) -> + <<"/d%C3%A4r">> = + uri_string:recompose(#{path => <<"/där"/utf8>>}), + <<"/d%C3%A4r#n%C3%A4sa">> = + uri_string:recompose(#{path => <<"/där"/utf8>>, + fragment => <<"näsa"/utf8>>}), + <<"/d%C3%A4r?name=%C3%B6rn">> = + uri_string:recompose(#{path => <<"/där"/utf8>>, + query => <<"name=örn"/utf8>>}), + <<"/d%C3%A4r?name=%C3%B6rn#n%C3%A4sa">> = + uri_string:recompose(#{path => <<"/där"/utf8>>, + query => <<"name=örn"/utf8>>, + fragment => <<"näsa"/utf8>>}), + + + "/d%C3%A4r" = + uri_string:recompose(#{path => "/där"}), + "/d%C3%A4r#n%C3%A4sa" = + uri_string:recompose(#{path => "/där", + fragment => "näsa"}), + "/d%C3%A4r?name=%C3%B6rn" = + uri_string:recompose(#{path => "/där", + query => "name=örn"}), + "/d%C3%A4r?name=%C3%B6rn#n%C3%A4sa" = + uri_string:recompose(#{path => "/där", + query => "name=örn", + fragment => "näsa"}). + + +recompose_parse_path(_Config) -> + <<"/d%C3%A4r">> = + uri_string:recompose(uri_string:parse(<<"/d%C3%A4r">>)), + <<"/d%C3%A4r#n%C3%A4sa">> = + uri_string:recompose(uri_string:parse(<<"/d%C3%A4r#n%C3%A4sa">>)), + <<"/d%C3%A4r?name=%C3%B6rn">> = + uri_string:recompose(uri_string:parse(<<"/d%C3%A4r?name=%C3%B6rn">>)), + + "/d%C3%A4r" = + uri_string:recompose(uri_string:parse("/d%C3%A4r")), + "/d%C3%A4r#n%C3%A4sa" = + uri_string:recompose(uri_string:parse("/d%C3%A4r#n%C3%A4sa")), + "/d%C3%A4r?name=%C3%B6rn" = + uri_string:recompose(uri_string:parse("/d%C3%A4r?name=%C3%B6rn")). + + +recompose_autogen(_Config) -> + Tests = generate_test_vectors(uri_combinations()), + lists:map(fun run_test_recompose/1, Tests). + +parse_recompose_autogen(_Config) -> + Tests = generate_test_vectors(uri_combinations()), + lists:map(fun run_test_parse_recompose/1, Tests). + +transcode_basic(_Config) -> + <<"foo%C3%B6bar"/utf8>> = + uri_string:transcode(<<"foo%00%00%00%F6bar"/utf32>>, [{in_encoding, utf32},{out_encoding, utf8}]), + "foo%C3%B6bar" = + uri_string:transcode("foo%00%00%00%F6bar", [{in_encoding, utf32},{out_encoding, utf8}]), + <<"foo%00%00%00%F6bar"/utf32>> = + uri_string:transcode(<<"foo%C3%B6bar"/utf8>>, [{in_encoding, utf8},{out_encoding, utf32}]), + "foo%00%00%00%F6bar" = + uri_string:transcode("foo%C3%B6bar", [{in_encoding, utf8},{out_encoding, utf32}]), + "foo%C3%B6bar" = + uri_string:transcode("foo%F6bar", [{in_encoding, latin1},{out_encoding, utf8}]). + +transcode_options(_Config) -> + <<"foo%C3%B6bar"/utf8>> = + uri_string:transcode(<<"foo%C3%B6bar"/utf8>>, []), + <<"foo%C3%B6bar"/utf8>> = + uri_string:transcode(<<"foo%00%00%00%F6bar"/utf32>>, [{in_encoding, utf32}]), + <<"foo%00%00%00%F6bar"/utf32>> = + uri_string:transcode(<<"foo%C3%B6bar"/utf8>>, [{out_encoding, utf32}]). + +transcode_mixed(_Config) -> + "foo%00%00%00%F6bar" = + uri_string:transcode(["foo",<<"%C3%B6"/utf8>>,<<"ba"/utf8>>,"r"], [{out_encoding, utf32}]), + "foo%00%00%00%F6bar" = + uri_string:transcode(["foo",<<"%C3%"/utf8>>,<<"B6ba"/utf8>>,"r"], [{out_encoding, utf32}]), + "foo%C3%B6bar" = + uri_string:transcode(["foo%00", <<"%00%0"/utf32>>,<<"0%F"/utf32>>,"6bar"], [{in_encoding, utf32},{out_encoding, utf8}]). + +transcode_negative(_Config) -> + {error,invalid_percent_encoding,"%BXbar"} = + uri_string:transcode(<<"foo%C3%BXbar"/utf8>>, [{in_encoding, utf8},{out_encoding, utf32}]), + {error,invalid_input,<<"ö">>} = + uri_string:transcode("foo%F6bar", [{in_encoding, utf8},{out_encoding, utf8}]). + +compose_query(_Config) -> + [] = uri_string:compose_query([]), + "foo=1&bar=2" = uri_string:compose_query([{<<"foo">>,"1"}, {"bar", "2"}]), + "foo=1&b%C3%A4r=2" = uri_string:compose_query([{"foo","1"}, {"bär", "2"}],[{encoding,utf8}]), + "foo=1&b%C3%A4r=2" = uri_string:compose_query([{"foo","1"}, {"bär", "2"}],[{encoding,unicode}]), + "foo=1&b%E4r=2" = uri_string:compose_query([{"foo","1"}, {"bär", "2"}],[{encoding,latin1}]), + "foo+bar=1&%E5%90%88=2" = uri_string:compose_query([{"foo bar","1"}, {"合", "2"}]), + "foo+bar=1&%26%2321512%3B=2" = + uri_string:compose_query([{"foo bar","1"}, {"合", "2"}],[{encoding,latin1}]), + "foo+bar=1&%C3%B6=2" = uri_string:compose_query([{<<"foo bar">>,<<"1">>}, {"ö", <<"2">>}]), + <<"foo+bar=1&%C3%B6=2">> = + uri_string:compose_query([{<<"foo bar">>,<<"1">>}, {<<"ö"/utf8>>, <<"2">>}]). + +compose_query_latin1(_Config) -> + Q = uri_string:compose_query([{"合foö bar","1"}, {"合", "合"}],[{encoding,latin1}]), + Q1 = uri_string:transcode(Q, [{in_encoding, latin1}]), + [{"合foö bar","1"}, {"合", "合"}] = uri_string:dissect_query(Q1), + Q2 = uri_string:compose_query([{<<"合foö bar"/utf8>>,<<"1">>}, {<<"合"/utf8>>, <<"合"/utf8>>}], + [{encoding,latin1}]), + Q3 = uri_string:transcode(Q2, [{in_encoding, latin1}]), + [{<<"合foö bar"/utf8>>,<<"1">>}, {<<"合"/utf8>>, <<"合"/utf8>>}] = + uri_string:dissect_query(Q3). + +compose_query_negative(_Config) -> + {error,invalid_input,4} = uri_string:compose_query([{"",4}]), + {error,invalid_input,5} = uri_string:compose_query([{5,""}]), + {error,invalid_encoding,utf16} = + uri_string:compose_query([{"foo bar","1"}, {<<"ö">>, "2"}],[{encoding,utf16}]). + +dissect_query(_Config) -> + [] = uri_string:dissect_query(""), + [{"foo","1"}, {"amp;bar", "2"}] = uri_string:dissect_query("foo=1&bar=2"), + [{"foo","1"}, {"bar", "2"}] = uri_string:dissect_query("foo=1&bar=2"), + [{"foo","1;bar=2"}] = uri_string:dissect_query("foo=1;bar=2"), + [{"foo","1"}, {"bar", "222"}] = uri_string:dissect_query([<<"foo=1&bar=2">>,"22"]), + [{"foo","ö"}, {"bar", "2"}] = uri_string:dissect_query("foo=%C3%B6&bar=2"), + [{<<"foo">>,<<"ö"/utf8>>}, {<<"bar">>, <<"2">>}] = + uri_string:dissect_query(<<"foo=%C3%B6&bar=2">>), + [{"foo bar","1"},{"ö","2"}] = + uri_string:dissect_query([<<"foo+bar=1&">>,<<"%C3%B6=2">>]), + [{"foo bar","1"},{[21512],"2"}] = + uri_string:dissect_query("foo+bar=1&%26%2321512%3B=2"), + [{<<"foo bar">>,<<"1">>},{<<"合"/utf8>>,<<"2">>}] = + uri_string:dissect_query(<<"foo+bar=1&%26%2321512%3B=2">>), + [{"föo bar","1"},{"ö","2"}] = + uri_string:dissect_query("föo+bar=1&%C3%B6=2"), + [{<<"föo bar"/utf8>>,<<"1">>},{<<"ö"/utf8>>,<<"2">>}] = + uri_string:dissect_query(<<"föo+bar=1&%C3%B6=2"/utf8>>). + +dissect_query_negative(_Config) -> + {error,missing_value,"&"} = + uri_string:dissect_query("foo1&bar=2"), + {error,invalid_percent_encoding,"%XX%B6"} = uri_string:dissect_query("foo=%XX%B6&bar=2"), + {error,invalid_input,[153]} = + uri_string:dissect_query("foo=%99%B6&bar=2"), + {error,invalid_character,"ö"} = uri_string:dissect_query(<<"föo+bar=1&%C3%B6=2">>), + {error,invalid_input,<<"ö">>} = + uri_string:dissect_query([<<"foo+bar=1&">>,<<"%C3%B6=2ö">>]). + +normalize(_Config) -> + "/a/g" = uri_string:normalize("/a/b/c/./../../g"), + <<"mid/6">> = uri_string:normalize(<<"mid/content=5/../6">>), + "http://localhost-%C3%B6rebro/a/g" = + uri_string:normalize("http://localhos%74-%c3%b6rebro:80/a/b/c/./../../g"), + <<"http://localhost-%C3%B6rebro/a/g">> = + uri_string:normalize(<<"http://localhos%74-%c3%b6rebro:80/a/b/c/./../../g">>), + <<"https://localhost/">> = + uri_string:normalize(<<"https://localhost:443">>), + <<"https://localhost:445/">> = + uri_string:normalize(<<"https://localhost:445">>), + <<"ftp://localhost">> = + uri_string:normalize(<<"ftp://localhost:21">>), + <<"ssh://localhost">> = + uri_string:normalize(<<"ssh://localhost:22">>), + <<"sftp://localhost">> = + uri_string:normalize(<<"sftp://localhost:22">>), + <<"tftp://localhost">> = + uri_string:normalize(<<"tftp://localhost:69">>). + +interop_query_utf8(_Config) -> + Q = uri_string:compose_query([{"foo bar","1"}, {"合", "2"}]), + Uri = uri_string:recompose(#{path => "/", query => Q}), + #{query := Q1} = uri_string:parse(Uri), + [{"foo bar","1"}, {"合", "2"}] = uri_string:dissect_query(Q1). + +interop_query_latin1(_Config) -> + Q = uri_string:compose_query([{"foo bar","1"}, {"合", "2"}], [{encoding,latin1}]), + Uri = uri_string:recompose(#{path => "/", query => Q}), + Uri1 = uri_string:transcode(Uri, [{in_encoding, latin1}]), + #{query := Q1} = uri_string:parse(Uri1), + [{"foo bar","1"}, {"合", "2"}] = uri_string:dissect_query(Q1). diff --git a/lib/stdlib/test/uri_string_property_test_SUITE.erl b/lib/stdlib/test/uri_string_property_test_SUITE.erl new file mode 100644 index 0000000000..ae2c61c7aa --- /dev/null +++ b/lib/stdlib/test/uri_string_property_test_SUITE.erl @@ -0,0 +1,39 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2008-2017. 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(uri_string_property_test_SUITE). + +-include_lib("common_test/include/ct.hrl"). +-compile(export_all). + +all() -> [recompose]. + +init_per_suite(Config) -> + ct_property_test:init_per_suite(Config). + +end_per_suite(Config) -> + Config. + +%%%======================================================================== +%%% Test suites +%%%======================================================================== +recompose(Config) -> + ct_property_test:quickcheck( + uri_string_recompose:prop_recompose(), + Config). diff --git a/lib/stdlib/uc_spec/gen_unicode_mod.escript b/lib/stdlib/uc_spec/gen_unicode_mod.escript index 674e5a0628..fe5a860d45 100755 --- a/lib/stdlib/uc_spec/gen_unicode_mod.escript +++ b/lib/stdlib/uc_spec/gen_unicode_mod.escript @@ -170,7 +170,7 @@ gen_header(Fd) -> io:put_chars(Fd, "-export([spec_version/0, lookup/1, get_case/1]).\n"), io:put_chars(Fd, "-inline([class/1]).\n"), io:put_chars(Fd, "-compile(nowarn_unused_vars).\n"), - io:put_chars(Fd, "-dialyzer({no_improper_lists, [cp/1, gc_prepend/2, gc_e_cont/2]}).\n"), + io:put_chars(Fd, "-dialyzer({no_improper_lists, [cp/1, gc/1, gc_prepend/2, gc_e_cont/2]}).\n"), io:put_chars(Fd, "-type gc() :: char()|[char()].\n\n\n"), ok. @@ -240,7 +240,7 @@ gen_norm(Fd) -> "-spec nfd(unicode:chardata()) -> maybe_improper_list(gc(),unicode:chardata()) | {error, unicode:chardata()}.\n" "nfd(Str0) ->\n" " case gc(Str0) of\n" - " [GC|R] when GC < 127 -> [GC|R];\n" + " [GC|R] when GC < 128 -> [GC|R];\n" " [GC|Str] -> [decompose(GC)|Str];\n" " [] -> [];\n" " {error,_}=Error -> Error\n end.\n\n" @@ -250,7 +250,7 @@ gen_norm(Fd) -> "-spec nfkd(unicode:chardata()) -> maybe_improper_list(gc(),unicode:chardata()) | {error, unicode:chardata()}.\n" "nfkd(Str0) ->\n" " case gc(Str0) of\n" - " [GC|R] when GC < 127 -> [GC|R];\n" + " [GC|R] when GC < 128 -> [GC|R];\n" " [GC|Str] -> [decompose_compat(GC)|Str];\n" " [] -> [];\n" " {error,_}=Error -> Error\n end.\n\n" @@ -260,7 +260,7 @@ gen_norm(Fd) -> "-spec nfc(unicode:chardata()) -> maybe_improper_list(gc(),unicode:chardata()) | {error, unicode:chardata()}.\n" "nfc(Str0) ->\n" " case gc(Str0) of\n" - " [GC|R] when GC < 255 -> [GC|R];\n" + " [GC|R] when GC < 256 -> [GC|R];\n" " [GC|Str] -> [compose(decompose(GC))|Str];\n" " [] -> [];\n" " {error,_}=Error -> Error\n end.\n\n" @@ -270,7 +270,7 @@ gen_norm(Fd) -> "-spec nfkc(unicode:chardata()) -> maybe_improper_list(gc(),unicode:chardata()) | {error, unicode:chardata()}.\n" "nfkc(Str0) ->\n" " case gc(Str0) of\n" - " [GC|R] when GC < 127 -> [GC|R];\n" + " [GC|R] when GC < 128 -> [GC|R];\n" " [GC|Str] -> [compose_compat_0(decompose_compat(GC))|Str];\n" " [] -> [];\n" " {error,_}=Error -> Error\n end.\n\n" @@ -476,13 +476,30 @@ gen_gc(Fd, GBP) -> "-spec gc(String::unicode:chardata()) ->" " maybe_improper_list() | {error, unicode:chardata()}.\n"), io:put_chars(Fd, + "gc([CP1, CP2|_]=T)\n" + " when CP1 < 256, CP2 < 256, CP1 =/= $\r -> %% Ascii Fast path\n" + " T;\n" + "gc(<<CP1/utf8, Rest/binary>>) ->\n" + " if CP1 < 256, CP1 =/= $\r ->\n" + " case Rest of\n" + " <<CP2/utf8, _/binary>> when CP2 < 256 -> %% Ascii Fast path\n" + " [CP1|Rest];\n" + " _ -> gc_1([CP1|Rest])\n" + " end;\n" + " true -> gc_1([CP1|Rest])\n" + " end;\n" "gc(Str) ->\n" " gc_1(cp(Str)).\n\n" "gc_1([$\\r|R0] = R) ->\n" " case cp(R0) of % Don't break CRLF\n" " [$\\n|R1] -> [[$\\r,$\\n]|R1];\n" " _ -> R\n" - " end;\n"), + " end;\n" + %% "gc_1([CP1, CP2|_]=T) when CP1 < 256, CP2 < 256 ->\n" + %% " T; %% Fast path\n" + %% "gc_1([CP1|<<CP2/utf8, _/binary>>]=T) when CP1 < 256, CP2 < 256 ->\n" + %% " T; %% Fast path\n" + ), io:put_chars(Fd, "%% Handle control\n"), GenControl = fun(Range) -> io:format(Fd, "gc_1~s R0;\n", [gen_clause(Range)]) end, @@ -490,7 +507,7 @@ gen_gc(Fd, GBP) -> [R1,R2,R3|Crs] = CRs0, [GenControl(CP) || CP <- merge_ranges([R1,R2,R3], split), CP =/= {$\r, undefined}], %%GenControl(R1),GenControl(R2),GenControl(R3), - io:format(Fd, "gc_1([CP|R]) when CP < 255 -> gc_extend(R,CP);\n", []), + io:format(Fd, "gc_1([CP|R]) when CP < 256 -> gc_extend(R,CP);\n", []), [GenControl(CP) || CP <- Crs], %% One clause per CP %% CRs0 = merge_ranges(maps:get(cr, GBP) ++ maps:get(lf, GBP) ++ maps:get(control, GBP)), diff --git a/lib/stdlib/vsn.mk b/lib/stdlib/vsn.mk index 48db5dc900..69d258c2f0 100644 --- a/lib/stdlib/vsn.mk +++ b/lib/stdlib/vsn.mk @@ -1 +1 @@ -STDLIB_VSN = 3.4.2 +STDLIB_VSN = 3.4.3 diff --git a/lib/syntax_tools/doc/src/notes.xml b/lib/syntax_tools/doc/src/notes.xml index 8c91f01e3b..bd2bcde2c2 100644 --- a/lib/syntax_tools/doc/src/notes.xml +++ b/lib/syntax_tools/doc/src/notes.xml @@ -32,6 +32,21 @@ <p>This document describes the changes made to the Syntax_Tools application.</p> +<section><title>Syntax_Tools 2.1.4</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + <section><title>Syntax_Tools 2.1.3</title> <section><title>Improvements and New Features</title> diff --git a/lib/syntax_tools/src/erl_prettypr.erl b/lib/syntax_tools/src/erl_prettypr.erl index 40ddd2b22a..60a15c8e3f 100644 --- a/lib/syntax_tools/src/erl_prettypr.erl +++ b/lib/syntax_tools/src/erl_prettypr.erl @@ -774,9 +774,16 @@ lay_2(Node, Ctxt) -> class_qualifier -> Ctxt1 = set_prec(Ctxt, max_prec()), D1 = lay(erl_syntax:class_qualifier_argument(Node), Ctxt1), - D2 = lay(erl_syntax:class_qualifier_body(Node), Ctxt1), - beside(D1, beside(text(":"), D2)); - + D2 = lay(erl_syntax:class_qualifier_body(Node), Ctxt1), + Stacktrace = erl_syntax:class_qualifier_stacktrace(Node), + case erl_syntax:variable_name(Stacktrace) of + '_' -> + beside(D1, beside(text(":"), D2)); + _ -> + D3 = lay(Stacktrace, Ctxt1), + beside(D1, beside(beside(text(":"), D2), + beside(text(":"), D3))) + end; comment -> D = stack_comment_lines( erl_syntax:comment_text(Node)), diff --git a/lib/syntax_tools/src/erl_syntax.erl b/lib/syntax_tools/src/erl_syntax.erl index 9b2b503762..b816c0699c 100644 --- a/lib/syntax_tools/src/erl_syntax.erl +++ b/lib/syntax_tools/src/erl_syntax.erl @@ -342,8 +342,10 @@ typed_record_field_body/1, typed_record_field_type/1, class_qualifier/2, + class_qualifier/3, class_qualifier_argument/1, class_qualifier_body/1, + class_qualifier_stacktrace/1, tuple/1, tuple_elements/1, tuple_size/1, @@ -3884,7 +3886,7 @@ fold_try_clause({clause, Pos, [P], Guard, Body}) -> class_qualifier -> {tuple, Pos, [class_qualifier_argument(P), class_qualifier_body(P), - {var, Pos, '_'}]}; + class_qualifier_stacktrace(P)]}; _ -> {tuple, Pos, [{atom, Pos, throw}, P, {var, Pos, '_'}]} end, @@ -3893,12 +3895,14 @@ fold_try_clause({clause, Pos, [P], Guard, Body}) -> unfold_try_clauses(Cs) -> [unfold_try_clause(C) || C <- Cs]. -unfold_try_clause({clause, Pos, [{tuple, _, [{atom, _, throw}, V, _]}], +unfold_try_clause({clause, Pos, [{tuple, _, [{atom, _, throw}, + V, + [{var, _, '_'}]]}], Guard, Body}) -> {clause, Pos, [V], Guard, Body}; -unfold_try_clause({clause, Pos, [{tuple, _, [C, V, _]}], +unfold_try_clause({clause, Pos, [{tuple, _, [C, V, Stacktrace]}], Guard, Body}) -> - {clause, Pos, [class_qualifier(C, V)], Guard, Body}. + {clause, Pos, [class_qualifier(C, V, Stacktrace)], Guard, Body}. %% ===================================================================== @@ -6725,9 +6729,12 @@ try_expr_after(Node) -> %% %% @see class_qualifier_argument/1 %% @see class_qualifier_body/1 +%% @see class_qualifier_stacktrace/1 %% @see try_expr/4 --record(class_qualifier, {class :: syntaxTree(), body :: syntaxTree()}). +-record(class_qualifier, {class :: syntaxTree(), + body :: syntaxTree(), + stacktrace :: syntaxTree()}). %% type(Node) = class_qualifier %% data(Node) = #class_qualifier{class :: Class, body :: Body} @@ -6737,8 +6744,27 @@ try_expr_after(Node) -> -spec class_qualifier(syntaxTree(), syntaxTree()) -> syntaxTree(). class_qualifier(Class, Body) -> + Underscore = {var, get_pos(Body), '_'}, tree(class_qualifier, - #class_qualifier{class = Class, body = Body}). + #class_qualifier{class = Class, body = Body, + stacktrace = Underscore}). + +%% ===================================================================== +%% @doc Creates an abstract class qualifier. The result represents +%% "<code><em>Class</em>:<em>Body</em>:<em>Stacktrace</em></code>". +%% +%% @see class_qualifier_argument/1 +%% @see class_qualifier_body/1 +%% @see try_expr/4 + +-spec class_qualifier(syntaxTree(), syntaxTree(), syntaxTree()) -> + syntaxTree(). + +class_qualifier(Class, Body, Stacktrace) -> + tree(class_qualifier, + #class_qualifier{class = Class, + body = Body, + stacktrace = Stacktrace}). %% ===================================================================== @@ -6763,6 +6789,16 @@ class_qualifier_argument(Node) -> class_qualifier_body(Node) -> (data(Node))#class_qualifier.body. +%% ===================================================================== +%% @doc Returns the stacktrace subtree of a `class_qualifier' node. +%% +%% @see class_qualifier/2 + +-spec class_qualifier_stacktrace(syntaxTree()) -> syntaxTree(). + +class_qualifier_stacktrace(Node) -> + (data(Node))#class_qualifier.stacktrace. + %% ===================================================================== %% @doc Creates an abstract "implicit fun" expression. If @@ -7727,8 +7763,9 @@ subtrees(T) -> catch_expr -> [[catch_expr_body(T)]]; class_qualifier -> - [[class_qualifier_argument(T)], - [class_qualifier_body(T)]]; + [[class_qualifier_argument(T)], + [class_qualifier_body(T)], + [class_qualifier_stacktrace(T)]]; clause -> case clause_guard(T) of none -> @@ -7949,6 +7986,7 @@ make_tree(block_expr, [B]) -> block_expr(B); make_tree(case_expr, [[A], C]) -> case_expr(A, C); make_tree(catch_expr, [[B]]) -> catch_expr(B); make_tree(class_qualifier, [[A], [B]]) -> class_qualifier(A, B); +make_tree(class_qualifier, [[A], [B], [C]]) -> class_qualifier(A, B, C); make_tree(clause, [P, B]) -> clause(P, none, B); make_tree(clause, [P, [G], B]) -> clause(P, G, B); make_tree(cond_expr, [C]) -> cond_expr(C); diff --git a/lib/syntax_tools/vsn.mk b/lib/syntax_tools/vsn.mk index e0880d61ee..8d37c40742 100644 --- a/lib/syntax_tools/vsn.mk +++ b/lib/syntax_tools/vsn.mk @@ -1 +1 @@ -SYNTAX_TOOLS_VSN = 2.1.3 +SYNTAX_TOOLS_VSN = 2.1.4 diff --git a/lib/tools/doc/src/Makefile b/lib/tools/doc/src/Makefile index 7011f869cd..b554781382 100644 --- a/lib/tools/doc/src/Makefile +++ b/lib/tools/doc/src/Makefile @@ -58,8 +58,7 @@ XML_CHAPTER_FILES = \ lcnt_chapter.xml \ erlang_mode_chapter.xml \ xref_chapter.xml \ - notes.xml \ - notes_history.xml + notes.xml BOOK_FILES = book.xml diff --git a/lib/tools/doc/src/notes.xml b/lib/tools/doc/src/notes.xml index 3eaa2058a0..1edc08c9cd 100644 --- a/lib/tools/doc/src/notes.xml +++ b/lib/tools/doc/src/notes.xml @@ -31,6 +31,21 @@ </header> <p>This document describes the changes made to the Tools application.</p> +<section><title>Tools 2.11.1</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + <section><title>Tools 2.11</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/tools/emacs/erlang.el b/lib/tools/emacs/erlang.el index 429188b028..6b93d63182 100644 --- a/lib/tools/emacs/erlang.el +++ b/lib/tools/emacs/erlang.el @@ -885,7 +885,6 @@ resulting regexp is surrounded by \\_< and \\_>." "append" "append_element" "await_proc_exit" - "await_sched_wall_time_modifications" "bump_reductions" "call_on_load_function" "cancel_timer" @@ -895,8 +894,6 @@ resulting regexp is surrounded by \\_< and \\_>." "decode_packet" "delay_trap" "delete_element" - "dexit" - "dgroup_leader" "display" "display_nl" "display_string" @@ -905,11 +902,8 @@ resulting regexp is surrounded by \\_< and \\_>." "dist_ctrl_get_data_notification" "dist_ctrl_input_handler" "dist_ctrl_put_data" - "dist_exit" - "dlink" "dmonitor_node" "dmonitor_p" - "dsend" "dt_append_vm_tag_data" "dt_get_tag" "dt_get_tag_data" @@ -917,7 +911,6 @@ resulting regexp is surrounded by \\_< and \\_>." "dt_put_tag" "dt_restore_tag" "dt_spread_tag" - "dunlink" "convert_time_unit" "external_size" "finish_after_on_load" @@ -929,7 +922,6 @@ resulting regexp is surrounded by \\_< and \\_>." "function_exported" "garbage_collect_message_area" "gather_gc_info_result" - "gather_sched_wall_time_result" "get_cookie" "get_module_info" "get_stacktrace" diff --git a/lib/tools/src/cover.erl b/lib/tools/src/cover.erl index 801bbc7461..bf5faa165d 100644 --- a/lib/tools/src/cover.erl +++ b/lib/tools/src/cover.erl @@ -2456,7 +2456,9 @@ do_analyse_to_file1(Module, OutFile, ErlFile, HTML) -> Pattern = {#bump{module=Module,line='$1',_='_'},'$2'}, MS = [{Pattern,[{is_integer,'$1'},{'>','$1',0}],[{{'$1','$2'}}]}], - CovLines = lists:keysort(1,ets:select(?COLLECTION_TABLE, MS)), + CovLines0 = + lists:keysort(1, ets:select(?COLLECTION_TABLE, MS)), + CovLines = merge_dup_lines(CovLines0), print_lines(Module, CovLines, InFd, OutFd, 1, HTML), if HTML -> @@ -2477,19 +2479,23 @@ do_analyse_to_file1(Module, OutFile, ErlFile, HTML) -> {error, {file, ErlFile, Reason}} end. +merge_dup_lines(CovLines) -> + merge_dup_lines(CovLines, []). +merge_dup_lines([{L, N}|T], [{L, NAcc}|TAcc]) -> + merge_dup_lines(T, [{L, NAcc + N}|TAcc]); +merge_dup_lines([{L, N}|T], Acc) -> + merge_dup_lines(T, [{L, N}|Acc]); +merge_dup_lines([], Acc) -> + lists:reverse(Acc). print_lines(Module, CovLines, InFd, OutFd, L, HTML) -> case file:read_line(InFd) of eof -> ignore; - {ok,"%"++_=Line} -> %Comment line - not executed. - ok = file:write(OutFd, [tab(),escape_lt_and_gt(Line, HTML)]), - print_lines(Module, CovLines, InFd, OutFd, L+1, HTML); {ok,RawLine} -> Line = escape_lt_and_gt(RawLine,HTML), case CovLines of [{L,N}|CovLines1] -> - %% N = lists:foldl(fun([Ni], Nacc) -> Nacc+Ni end, 0, Ns), if N=:=0, HTML=:=true -> LineNoNL = Line -- "\n", Str = " 0", @@ -2508,7 +2514,7 @@ print_lines(Module, CovLines, InFd, OutFd, L, HTML) -> ok = file:write(OutFd, [Str,fill3(),Line]) end, print_lines(Module, CovLines1, InFd, OutFd, L+1, HTML); - _ -> + _ -> %Including comment lines ok = file:write(OutFd, [tab(),Line]), print_lines(Module, CovLines, InFd, OutFd, L+1, HTML) end diff --git a/lib/tools/test/cover_SUITE.erl b/lib/tools/test/cover_SUITE.erl index 90e113c178..161b0105b9 100644 --- a/lib/tools/test/cover_SUITE.erl +++ b/lib/tools/test/cover_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2001-2016. All Rights Reserved. +%% Copyright Ericsson AB 2001-2017. 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. @@ -35,7 +35,7 @@ all() -> distribution, reconnect, die_and_reconnect, dont_reconnect_after_stop, stop_node_after_disconnect, export_import, otp_5031, otp_6115, - otp_8270, otp_10979_hanging_node], + otp_8270, otp_10979_hanging_node, otp_14817], case whereis(cover_server) of undefined -> [coverage,StartStop ++ NoStartStop]; @@ -1574,6 +1574,30 @@ otp_10979_hanging_node(_Config) -> ok. +otp_14817(Config) when is_list(Config) -> + Test = <<"-module(otp_14817). + -export([a/0, b/0, c/0, d/0]). + a() -> ok. b() -> ok. c() -> ok. + d() -> ok. + ">>, + File = cc_mod(otp_14817, Test, Config), + ok = otp_14817:a(), + ok = otp_14817:b(), + ok = otp_14817:c(), + ok = otp_14817:d(), + {ok,[{{otp_14817,3},1}, + {{otp_14817,3},1}, + {{otp_14817,3},1}, + {{otp_14817,4},1}]} = + cover:analyse(otp_14817, calls, line), + {ok, CovOut} = cover:analyse_to_file(otp_14817), + {ok, Bin} = file:read_file(CovOut), + <<"3..|",_/binary>> = string:find(Bin, "3..|"), + <<"1..|",_/binary>> = string:find(Bin, "1..|"), + ok = file:delete(File), + ok = file:delete(CovOut), + ok. + %% Take compiler options from beam in cover:compile_beam compile_beam_opts(Config) when is_list(Config) -> {ok, Cwd} = file:get_cwd(), diff --git a/lib/tools/test/fprof_SUITE.erl b/lib/tools/test/fprof_SUITE.erl index 8fd164a4b3..ae0e7253ad 100644 --- a/lib/tools/test/fprof_SUITE.erl +++ b/lib/tools/test/fprof_SUITE.erl @@ -51,7 +51,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}, - {timetrap,{seconds,60}}]. + {timetrap,{seconds,240}}]. all() -> case test_server:is_native(fprof_SUITE) of @@ -571,7 +571,7 @@ seq_r(Start, Stop, Succ, R) -> create_file_slow(Name, N) when is_integer(N), N >= 0 -> {ok, FD} = - file:open(Name, [raw, write, delayed_write, binary]), + file:open(Name, [raw, write, binary]), if N > 256 -> ok = file:write(FD, lists:map(fun (X) -> <<X:32/unsigned>> end, diff --git a/lib/tools/test/xref_SUITE.erl b/lib/tools/test/xref_SUITE.erl index d651cbcfee..018f632948 100644 --- a/lib/tools/test/xref_SUITE.erl +++ b/lib/tools/test/xref_SUITE.erl @@ -1112,27 +1112,16 @@ read_expected(Version) -> {POS7+2,{FF,{erlang,spawn_opt,4}}}, {POS8+1,{FF,{hej,san,1}}}, {POS8+4,{FF,{a,b,1}}}, - {POS8+4,{FF,{erlang,apply,2}}}, - {POS8+5,{FF,{erlang,apply,2}}}, {POS8+6,{FF,{m,f,1}}}, {POS9+1,{FF,{read,bi,0}}}, {POS9+2,{FF,{a,b,1}}}, - {POS9+2,{FF,{erlang,apply,2}}}, - {POS9+3,{FF,{erlang,apply,2}}}, - {POS9+4,{FF,{erlang,apply,2}}}, {POS9+4,{FF,{erlang,not_a_function,1}}}, {POS9+5,{FF,{mod,func,2}}}, {POS9+6,{FF,{erlang,apply,1}}}, - {POS9+7,{FF,{erlang,apply,2}}}, {POS9+7,{FF,{math,add3,1}}}, {POS9+8,{FF,{q,f,1}}}, - {POS10+4,{FF,{erlang,apply,2}}}, {POS10+5,{FF,{mod1,fun1,1}}}, - {POS11+6,{FF,{erlang,apply,2}}}, - {POS12+1,{FF,{erlang,apply,2}}}, - {POS12+4,{FF,{erlang,apply,2}}}, {POS12+5,{FF,{m3,f3,2}}}, - {POS12+7,{FF,{erlang,apply,2}}}, {POS13+1,{FF,{dm,df,1}}}, {POS13+6,{{read,bi,0},{foo,module_info,0}}}, {POS13+7,{{read,bi,0},{read,module_info,0}}}, @@ -1162,15 +1151,26 @@ read_expected(Version) -> {POS3+3, {FF,{erlang,spawn_link,3}}}, {POS3+4, {FF,{erlang,spawn_link,3}}}, {POS6+4, {FF,{erlang,spawn,3}}}, + {POS8+4,{FF,{erlang,apply,2}}}, + {POS8+5,{FF,{erlang,apply,2}}}, {POS8+6,{FF,{erlang,apply,3}}}, {POS8+7,{FF,{erlang,apply,3}}}, {POS9+1,{FF,{erlang,apply,3}}}, + {POS9+2,{FF,{erlang,apply,2}}}, + {POS9+3,{FF,{erlang,apply,2}}}, + {POS9+4,{FF,{erlang,apply,2}}}, {POS9+5,{FF,{erlang,apply,3}}}, + {POS9+7,{FF,{erlang,apply,2}}}, + {POS10+4,{FF,{erlang,apply,2}}}, {POS11+1,{FF,{erlang,apply,3}}}, {POS11+2,{FF,{erlang,apply,3}}}, {POS11+3,{FF,{erlang,apply,3}}}, {POS11+4,{FF,{erlang,apply,3}}}, + {POS11+6,{FF,{erlang,apply,2}}}, + {POS12+1,{FF,{erlang,apply,2}}}, + {POS12+4,{FF,{erlang,apply,2}}}, {POS12+5,{FF,{erlang,apply,3}}}, + {POS12+7,{FF,{erlang,apply,2}}}, {POS12+8,{FF,{erlang,apply,3}}}, {POS13+5, {{read,bi,0},{erlang,length,1}}}, {POS14+3, {{read,bi,0},{erlang,length,1}}}], diff --git a/lib/tools/vsn.mk b/lib/tools/vsn.mk index b9249ae45c..6cafbca6a7 100644 --- a/lib/tools/vsn.mk +++ b/lib/tools/vsn.mk @@ -1 +1 @@ -TOOLS_VSN = 2.11 +TOOLS_VSN = 2.11.1 diff --git a/lib/wx/c_src/wxe_ps_init.c b/lib/wx/c_src/wxe_ps_init.c index e6b677d469..277f3ac25f 100644 --- a/lib/wx/c_src/wxe_ps_init.c +++ b/lib/wx/c_src/wxe_ps_init.c @@ -61,13 +61,20 @@ int is_packaged_app() { void * wxe_ps_init2() { NSAutoreleasePool *pool; ProcessSerialNumber psn; - + size_t app_len = 127; + char app_title_buf[128]; + char * app_title; // Setup and enable gui pool = [[NSAutoreleasePool alloc] init]; - + if( !is_packaged_app() ) { // Undocumented function (but no documented way of doing this exists) - char *app_title = getenv("WX_APP_TITLE"); + int res = erl_drv_getenv("WX_APP_TITLE", app_title_buf, &app_len); + if (res >= 0) { + app_title = app_title_buf; + } else { + app_title = NULL; + } if(!GetCurrentProcess(&psn)) { CPSSetProcessName(&psn, app_title?app_title:"Erlang"); } diff --git a/lib/wx/doc/src/notes.xml b/lib/wx/doc/src/notes.xml index 599b5b64fd..69ea906ec0 100644 --- a/lib/wx/doc/src/notes.xml +++ b/lib/wx/doc/src/notes.xml @@ -32,6 +32,22 @@ <p>This document describes the changes made to the wxErlang application.</p> +<section><title>Wx 1.8.3</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + wx crashes in otp 20.1 if empty binaries was sent down as + arguments.</p> + <p> + Own Id: OTP-14688</p> + </item> + </list> + </section> + +</section> + <section><title>Wx 1.8.2</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/wx/src/wxe_master.erl b/lib/wx/src/wxe_master.erl index ce859b3eb3..a55917f0aa 100644 --- a/lib/wx/src/wxe_master.erl +++ b/lib/wx/src/wxe_master.erl @@ -122,16 +122,9 @@ init([SilentStart]) -> erlang:error(not_smp) end, - case os:type() of - {win32,_} -> %% Needed for mingwm10.dll - Path = os:getenv("PATH"), - os:putenv("PATH", PrivDir ++ ";" ++ Path); - _ -> ok - end, - case erl_ddll:load_driver(PrivDir,DriverName) of ok -> ok; - {error, What} -> + {error, What} -> wxe_util:opt_error_log(SilentStart, "WX Failed loading ~p@~p ~n", [DriverName,PrivDir]), @@ -139,8 +132,8 @@ init([SilentStart]) -> erlang:error({load_driver,Str}) end, process_flag(trap_exit, true), - DriverWithArgs = DriverName ++ " " ++ code:priv_dir(wx) ++ [0], - + DriverWithArgs = DriverName ++ " " ++ code:priv_dir(wx), + try Port = open_port({spawn, DriverWithArgs},[binary]), wx_debug_info = ets:new(wx_debug_info, [named_table]), diff --git a/lib/wx/vsn.mk b/lib/wx/vsn.mk index 039fae322e..7da4529c98 100644 --- a/lib/wx/vsn.mk +++ b/lib/wx/vsn.mk @@ -1 +1 @@ -WX_VSN = 1.8.2 +WX_VSN = 1.8.3 diff --git a/lib/xmerl/doc/src/notes.xml b/lib/xmerl/doc/src/notes.xml index 1162561225..f62a8dc53d 100644 --- a/lib/xmerl/doc/src/notes.xml +++ b/lib/xmerl/doc/src/notes.xml @@ -32,6 +32,21 @@ <p>This document describes the changes made to the Xmerl application.</p> +<section><title>Xmerl 1.3.16</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> Removed all old unused files in the documentation. + </p> + <p> + Own Id: OTP-14475 Aux Id: ERL-409, PR-1493 </p> + </item> + </list> + </section> + +</section> + <section><title>Xmerl 1.3.15</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/xmerl/vsn.mk b/lib/xmerl/vsn.mk index 2e9c9061d9..ddff0c8894 100644 --- a/lib/xmerl/vsn.mk +++ b/lib/xmerl/vsn.mk @@ -1 +1 @@ -XMERL_VSN = 1.3.15 +XMERL_VSN = 1.3.16 |
