xmpp.chapril.org-ejabberd/test/suite.erl

%%%-------------------------------------------------------------------
%%% Author  : Evgeny Khramtsov <ekhramtsov@process-one.net>
%%% Created : 27 Jun 2013 by Evgeniy Khramtsov <ekhramtsov@process-one.net>
%%%
%%%
%%% ejabberd, Copyright (C) 2002-2017   ProcessOne
%%%
%%% This program is free software; you can redistribute it and/or
%%% modify it under the terms of the GNU General Public License as
%%% published by the Free Software Foundation; either version 2 of the
%%% License, or (at your option) any later version.
%%%
%%% This program is distributed in the hope that it will be useful,
%%% but WITHOUT ANY WARRANTY; without even the implied warranty of
%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
%%% General Public License for more details.
%%%
%%% You should have received a copy of the GNU General Public License along
%%% with this program; if not, write to the Free Software Foundation, Inc.,
%%% 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
%%%
%%%----------------------------------------------------------------------

-module(suite).

%% API
-compile(export_all).

-include("suite.hrl").
-include_lib("kernel/include/file.hrl").
-include("mod_roster.hrl").

%%%===================================================================
%%% API
%%%===================================================================
init_config(Config) ->
    DataDir = proplists:get_value(data_dir, Config),
    PrivDir = proplists:get_value(priv_dir, Config),
    [_, _|Tail] = lists:reverse(filename:split(DataDir)),
    BaseDir = filename:join(lists:reverse(Tail)),
    ConfigPathTpl = filename:join([DataDir, "ejabberd.yml"]),
    LogPath = filename:join([PrivDir, "ejabberd.log"]),
    SASLPath = filename:join([PrivDir, "sasl.log"]),
    MnesiaDir = filename:join([PrivDir, "mnesia"]),
    CertFile = filename:join([DataDir, "cert.pem"]),
    SelfSignedCertFile = filename:join([DataDir, "self-signed-cert.pem"]),
    CAFile = filename:join([DataDir, "ca.pem"]),
    {ok, CWD} = file:get_cwd(),
    {ok, _} = file:copy(CertFile, filename:join([CWD, "cert.pem"])),
    {ok, _} = file:copy(SelfSignedCertFile,
			filename:join([CWD, "self-signed-cert.pem"])),
    {ok, _} = file:copy(CAFile, filename:join([CWD, "ca.pem"])),
    {ok, CfgContentTpl} = file:read_file(ConfigPathTpl),
    Password = <<"password!@#$%^&*()'\"`~<>+-/;:_=[]{}|\\">>,
    CfgContent = process_config_tpl(CfgContentTpl, [
                                                    {c2s_port, 5222},
                                                    {loglevel, 4},
                                                    {new_schema, false},
                                                    {s2s_port, 5269},
						    {component_port, 5270},
                                                    {web_port, 5280},
						    {password, Password},
                                                    {mysql_server, <<"localhost">>},
                                                    {mysql_port, 3306},
                                                    {mysql_db, <<"ejabberd_test">>},
                                                    {mysql_user, <<"ejabberd_test">>},
                                                    {mysql_pass, <<"ejabberd_test">>},
                                                    {pgsql_server, <<"localhost">>},
                                                    {pgsql_port, 5432},
                                                    {pgsql_db, <<"ejabberd_test">>},
                                                    {pgsql_user, <<"ejabberd_test">>},
                                                    {pgsql_pass, <<"ejabberd_test">>},
						    {priv_dir, PrivDir}
						   ]),
    HostTypes = re:split(CfgContent, "(\\s*- \"(.*)\\.localhost\")",
			 [group, {return, binary}]),
    Types = [binary_to_list(Type) || [_, _, Type] <- HostTypes],
    Backends = get_config_backends(Types),
    HostTypes = re:split(CfgContent, "(\\s*- \"(.*)\\.localhost\")",
			   [group, {return, binary}]),
    CfgContent2 = lists:foldl(fun([Pre, Frag, Type], Acc) ->
				      case lists:member(binary_to_list(Type), Backends) of
					  true ->
					      <<Acc/binary, Pre/binary, Frag/binary>>;
					  _ ->
					      <<Acc/binary, Pre/binary>>
				      end;
				 ([Rest], Acc) ->
				      <<Acc/binary, Rest/binary>>
			      end, <<>>, HostTypes),
    ConfigPath = filename:join([CWD, "ejabberd.yml"]),
    ok = file:write_file(ConfigPath, CfgContent2),
    setup_ejabberd_lib_path(Config),
    case application:load(sasl) of
	ok -> ok;
	{error, {already_loaded, _}} -> ok
    end,
    case application:load(mnesia) of
	ok -> ok;
	{error, {already_loaded, _}} -> ok
    end,
    case application:load(ejabberd) of
	ok -> ok;
	{error, {already_loaded, _}} -> ok
    end,
    application:set_env(ejabberd, config, ConfigPath),
    application:set_env(ejabberd, log_path, LogPath),
    application:set_env(sasl, sasl_error_logger, {file, SASLPath}),
    application:set_env(mnesia, dir, MnesiaDir),
    [{server_port, ct:get_config(c2s_port, 5222)},
     {server_host, "localhost"},
     {component_port, ct:get_config(component_port, 5270)},
     {s2s_port, ct:get_config(s2s_port, 5269)},
     {server, ?COMMON_VHOST},
     {user, <<"test_single!#$%^*()`~+-;_=[]{}|\\">>},
     {nick, <<"nick!@#$%^&*()'\"`~<>+-/;:_=[]{}|\\">>},
     {master_nick, <<"master_nick!@#$%^&*()'\"`~<>+-/;:_=[]{}|\\">>},
     {slave_nick, <<"slave_nick!@#$%^&*()'\"`~<>+-/;:_=[]{}|\\">>},
     {room_subject, <<"hello, world!@#$%^&*()'\"`~<>+-/;:_=[]{}|\\">>},
     {certfile, CertFile},
     {persistent_room, true},
     {anonymous, false},
     {type, client},
     {xmlns, ?NS_CLIENT},
     {ns_stream, ?NS_STREAM},
     {stream_version, {1, 0}},
     {stream_id, <<"">>},
     {stream_from, <<"">>},
     {db_xmlns, <<"">>},
     {mechs, []},
     {rosterver, false},
     {lang, <<"en">>},
     {base_dir, BaseDir},
     {receiver, undefined},
     {pubsub_node, <<"node!@#$%^&*()'\"`~<>+-/;:_=[]{}|\\">>},
     {pubsub_node_title, <<"title!@#$%^&*()'\"`~<>+-/;:_=[]{}|\\">>},
     {resource, <<"resource!@#$%^&*()'\"`~<>+-/;:_=[]{}|\\">>},
     {master_resource, <<"master_resource!@#$%^&*()'\"`~<>+-/;:_=[]{}|\\">>},
     {slave_resource, <<"slave_resource!@#$%^&*()'\"`~<>+-/;:_=[]{}|\\">>},
     {password, Password},
     {backends, Backends}
     |Config].

find_top_dir(Dir) ->
    case file:read_file_info(filename:join([Dir, ebin])) of
	{ok, #file_info{type = directory}} ->
	    Dir;
	_ ->
	    find_top_dir(filename:dirname(Dir))
    end.

setup_ejabberd_lib_path(Config) ->
    case code:lib_dir(ejabberd) of
	{error, _} ->
	    DataDir = proplists:get_value(data_dir, Config),
	    {ok, CWD} = file:get_cwd(),
	    NewEjPath = filename:join([CWD, "ejabberd-0.0.1"]),
	    TopDir = find_top_dir(DataDir),
	    ok = file:make_symlink(TopDir, NewEjPath),
	    code:replace_path(ejabberd, NewEjPath);
	_ ->
	    ok
    end.

%% Read environment variable CT_DB=riak,mysql to limit the backends to test.
%% You can thus limit the backend you want to test with:
%%  CT_BACKENDS=riak,mysql rebar ct suites=ejabberd
get_config_backends(Types) ->
    EnvBackends = case os:getenv("CT_BACKENDS") of
		      false  -> Types;
		      String ->
			  Backends0 = string:tokens(String, ","),
			  lists:map(fun(Backend) -> string:strip(Backend, both, $ ) end, Backends0)
		  end,
    application:load(ejabberd),
    EnabledBackends = lists:map(fun(V) when is_atom(V) ->
					atom_to_list(V);
				   (V) ->
					V
				end,
			       application:get_env(ejabberd, enabled_backends, Types)),
    lists:foldl(fun(Backend, Backends) ->
			case lists:member(Backend, EnabledBackends) of
			    false ->
				lists:delete(Backend, Backends);
			    _ ->
				Backends
			end
		end, EnvBackends, ["odbc", "mysql", "pgsql",
				   "sqlite", "riak", "redis"]).

process_config_tpl(Content, []) ->
    Content;
process_config_tpl(Content, [{Name, DefaultValue} | Rest]) ->
    Val = case ct:get_config(Name, DefaultValue) of
              V when is_integer(V) ->
                  integer_to_binary(V);
              V when is_atom(V) ->
                  atom_to_binary(V, latin1);
              V ->
                  iolist_to_binary(V)
          end,
    NewContent = binary:replace(Content,
				<<"@@",(atom_to_binary(Name,latin1))/binary, "@@">>,
				Val, [global]),
    process_config_tpl(NewContent, Rest).

stream_header(Config) ->
    To = case ?config(server, Config) of
	     <<"">> -> undefined;
	     Server -> jid:make(Server)
	 end,
    From = case ?config(stream_from, Config) of
	       <<"">> -> undefined;
	       Frm -> jid:make(Frm)
	   end,
    #stream_start{to = To,
		  from = From,
		  lang = ?config(lang, Config),
		  version = ?config(stream_version, Config),
		  xmlns = ?config(xmlns, Config),
		  db_xmlns = ?config(db_xmlns, Config),
		  stream_xmlns = ?config(ns_stream, Config)}.

connect(Config) ->
    NewConfig = init_stream(Config),
    case ?config(type, NewConfig) of
	client -> process_stream_features(NewConfig);
	server -> process_stream_features(NewConfig);
	component -> NewConfig
    end.

tcp_connect(Config) ->
    case ?config(receiver, Config) of
	undefined ->
	    Owner = self(),
	    NS = case ?config(type, Config) of
		     client -> ?NS_CLIENT;
		     server -> ?NS_SERVER;
		     component -> ?NS_COMPONENT
		 end,
	    Server = ?config(server_host, Config),
	    Port = ?config(server_port, Config),
	    ReceiverPid = spawn(fun() ->
					start_receiver(NS, Owner, Server, Port)
				end),
	    set_opt(receiver, ReceiverPid, Config);
	_ ->
	    Config
    end.

init_stream(Config) ->
    Version = ?config(stream_version, Config),
    NewConfig = tcp_connect(Config),
    send(NewConfig, stream_header(NewConfig)),
    XMLNS = case ?config(type, Config) of
		client -> ?NS_CLIENT;
		component -> ?NS_COMPONENT;
		server -> ?NS_SERVER
	    end,
    receive
	#stream_start{id = ID, xmlns = XMLNS, version = Version} ->
	    set_opt(stream_id, ID, NewConfig)
    end.

process_stream_features(Config) ->
    receive
	#stream_features{sub_els = Fs} ->
	    Mechs = lists:flatmap(
		      fun(#sasl_mechanisms{list = Ms}) ->
			      Ms;
			 (_) ->
			      []
		      end, Fs),
	    lists:foldl(
	      fun(#feature_register{}, Acc) ->
		      set_opt(register, true, Acc);
		 (#starttls{}, Acc) ->
		      set_opt(starttls, true, Acc);
		 (#legacy_auth_feature{}, Acc) ->
		      set_opt(legacy_auth, true, Acc);
		 (#compression{methods = Ms}, Acc) ->
		      set_opt(compression, Ms, Acc);
		 (_, Acc) ->
		      Acc
	      end, set_opt(mechs, Mechs, Config), Fs)
    end.

disconnect(Config) ->
    ct:comment("Disconnecting"),
    try
	send_text(Config, ?STREAM_TRAILER)
    catch exit:normal ->
	    ok
    end,
    receive {xmlstreamend, <<"stream:stream">>} -> ok end,
    flush(Config),
    ok = recv_call(Config, close),
    ct:comment("Disconnected"),
    set_opt(receiver, undefined, Config).

close_socket(Config) ->
    ok = recv_call(Config, close),
    Config.

starttls(Config) ->
    starttls(Config, false).

starttls(Config, ShouldFail) ->
    send(Config, #starttls{}),
    receive
	#starttls_proceed{} when ShouldFail ->
	    ct:fail(starttls_should_have_failed);
	#starttls_failure{} when ShouldFail ->
	    Config;
	#starttls_failure{} ->
	    ct:fail(starttls_failed);
	#starttls_proceed{} ->
	    ok = recv_call(Config, {starttls, ?config(certfile, Config)}),
	    Config
    end.

zlib(Config) ->
    send(Config, #compress{methods = [<<"zlib">>]}),
    receive #compressed{} -> ok end,
    ok = recv_call(Config, compress),
    process_stream_features(init_stream(Config)).

auth(Config) ->
    auth(Config, false).

auth(Config, ShouldFail) ->
    Type = ?config(type, Config),
    IsAnonymous = ?config(anonymous, Config),
    Mechs = ?config(mechs, Config),
    HaveMD5 = lists:member(<<"DIGEST-MD5">>, Mechs),
    HavePLAIN = lists:member(<<"PLAIN">>, Mechs),
    HaveExternal = lists:member(<<"EXTERNAL">>, Mechs),
    HaveAnonymous = lists:member(<<"ANONYMOUS">>, Mechs),
    if HaveAnonymous and IsAnonymous ->
	    auth_SASL(<<"ANONYMOUS">>, Config, ShouldFail);
       HavePLAIN ->
            auth_SASL(<<"PLAIN">>, Config, ShouldFail);
       HaveMD5 ->
            auth_SASL(<<"DIGEST-MD5">>, Config, ShouldFail);
       HaveExternal ->
	    auth_SASL(<<"EXTERNAL">>, Config, ShouldFail);
       Type == client ->
	    auth_legacy(Config, false, ShouldFail);
       Type == component ->
	    auth_component(Config, ShouldFail);
       true ->
	    ct:fail(no_known_sasl_mechanism_available)
    end.

bind(Config) ->
    U = ?config(user, Config),
    S = ?config(server, Config),
    R = ?config(resource, Config),
    case ?config(type, Config) of
	client ->
	    #iq{type = result, sub_els = [#bind{jid = JID}]} =
		send_recv(
		  Config, #iq{type = set, sub_els = [#bind{resource = R}]}),
	    case ?config(anonymous, Config) of
		false ->
		    {U, S, R} = jid:tolower(JID),
		    Config;
		true ->
		    {User, S, Resource} = jid:tolower(JID),
		    set_opt(user, User, set_opt(resource, Resource, Config))
	    end;
	component ->
	    Config
    end.

open_session(Config) ->
    open_session(Config, false).

open_session(Config, Force) ->
    if Force ->
	    #iq{type = result, sub_els = []} =
		send_recv(Config, #iq{type = set, sub_els = [#xmpp_session{}]});
       true ->
	    ok
    end,
    Config.

auth_legacy(Config, IsDigest) ->
    auth_legacy(Config, IsDigest, false).

auth_legacy(Config, IsDigest, ShouldFail) ->
    ServerJID = server_jid(Config),
    U = ?config(user, Config),
    R = ?config(resource, Config),
    P = ?config(password, Config),
    #iq{type = result,
	from = ServerJID,
	sub_els = [#legacy_auth{username = <<"">>,
				password = <<"">>,
				resource = <<"">>} = Auth]} =
	send_recv(Config,
		  #iq{to = ServerJID, type = get,
		      sub_els = [#legacy_auth{}]}),
    Res = case Auth#legacy_auth.digest of
	      <<"">> when IsDigest ->
		  StreamID = ?config(stream_id, Config),
		  D = p1_sha:sha(<<StreamID/binary, P/binary>>),
		  send_recv(Config, #iq{to = ServerJID, type = set,
					sub_els = [#legacy_auth{username = U,
								resource = R,
								digest = D}]});
	      _ when not IsDigest ->
		  send_recv(Config, #iq{to = ServerJID, type = set,
					sub_els = [#legacy_auth{username = U,
								resource = R,
								password = P}]})
	  end,
    case Res of
	#iq{from = ServerJID, type = result, sub_els = []} ->
	    if ShouldFail ->
		    ct:fail(legacy_auth_should_have_failed);
	       true ->
		    Config
	    end;
	#iq{from = ServerJID, type = error} ->
	    if ShouldFail ->
		    Config;
	       true ->
		    ct:fail(legacy_auth_failed)
	    end
    end.

auth_component(Config, ShouldFail) ->
    StreamID = ?config(stream_id, Config),
    Password = ?config(password, Config),
    Digest = p1_sha:sha(<<StreamID/binary, Password/binary>>),
    send(Config, #handshake{data = Digest}),
    receive
	#handshake{} when ShouldFail ->
	    ct:fail(component_auth_should_have_failed);
	#handshake{} ->
	    Config;
	#stream_error{reason = 'not-authorized'} when ShouldFail ->
	    Config;
	#stream_error{reason = 'not-authorized'} ->
	    ct:fail(component_auth_failed)
    end.

auth_SASL(Mech, Config) ->
    auth_SASL(Mech, Config, false).

auth_SASL(Mech, Config, ShouldFail) ->
    Creds = {?config(user, Config),
	     ?config(server, Config),
	     ?config(password, Config)},
    auth_SASL(Mech, Config, ShouldFail, Creds).

auth_SASL(Mech, Config, ShouldFail, Creds) ->
    {Response, SASL} = sasl_new(Mech, Creds),
    send(Config, #sasl_auth{mechanism = Mech, text = Response}),
    wait_auth_SASL_result(set_opt(sasl, SASL, Config), ShouldFail).

wait_auth_SASL_result(Config, ShouldFail) ->
    receive
	#sasl_success{} when ShouldFail ->
	    ct:fail(sasl_auth_should_have_failed);
        #sasl_success{} ->
	    ok = recv_call(Config, reset_stream),
            send(Config, stream_header(Config)),
	    Type = ?config(type, Config),
	    NS = if Type == client -> ?NS_CLIENT;
		    Type == server -> ?NS_SERVER
		 end,
	    Config2 = receive #stream_start{id = ID, xmlns = NS, version = {1,0}} ->
		set_opt(stream_id, ID, Config)
	    end,
            receive #stream_features{sub_els = Fs} ->
		    if Type == client ->
			    #xmpp_session{optional = true} =
				lists:keyfind(xmpp_session, 1, Fs);
		       true ->
			    ok
		    end,
		    lists:foldl(
		      fun(#feature_sm{}, ConfigAcc) ->
			      set_opt(sm, true, ConfigAcc);
			 (#feature_csi{}, ConfigAcc) ->
			      set_opt(csi, true, ConfigAcc);
			 (#rosterver_feature{}, ConfigAcc) ->
			      set_opt(rosterver, true, ConfigAcc);
			 (_, ConfigAcc) ->
			      ConfigAcc
		      end, Config2, Fs)
	    end;
        #sasl_challenge{text = ClientIn} ->
            {Response, SASL} = (?config(sasl, Config))(ClientIn),
            send(Config, #sasl_response{text = Response}),
            wait_auth_SASL_result(set_opt(sasl, SASL, Config), ShouldFail);
	#sasl_failure{} when ShouldFail ->
	    Config;
        #sasl_failure{} ->
            ct:fail(sasl_auth_failed)
    end.

re_register(Config) ->
    User = ?config(user, Config),
    Server = ?config(server, Config),
    Pass = ?config(password, Config),
    ok = ejabberd_auth:try_register(User, Server, Pass).

match_failure(Received, [Match]) when is_list(Match)->
    ct:fail("Received input:~n~n~p~n~ndon't match expected patterns:~n~n~s", [Received, Match]);
match_failure(Received, Matches) ->
    ct:fail("Received input:~n~n~p~n~ndon't match expected patterns:~n~n~p", [Received, Matches]).

recv(_Config) ->
    receive
	{fail, El, Why} ->
	    ct:fail("recv failed: ~p->~n~s",
		    [El, xmpp:format_error(Why)]);
	Event ->
	    Event
    end.

recv_iq(_Config) ->
    receive #iq{} = IQ -> IQ end.

recv_presence(_Config) ->
    receive #presence{} = Pres -> Pres end.

recv_message(_Config) ->
    receive #message{} = Msg -> Msg end.

decode_stream_element(NS, El) ->
    decode(El, NS, []).

format_element(El) ->
    case erlang:function_exported(ct, log, 5) of
	true -> ejabberd_web_admin:pretty_print_xml(El);
	false -> io_lib:format("~p~n", [El])
    end.

decode(El, NS, Opts) ->
    try
	Pkt = xmpp:decode(El, NS, Opts),
	ct:pal("RECV:~n~s~n~s",
	       [format_element(El), xmpp:pp(Pkt)]),
	Pkt
    catch _:{xmpp_codec, Why} ->
	    ct:pal("recv failed: ~p->~n~s",
		   [El, xmpp:format_error(Why)]),
	    erlang:error({xmpp_codec, Why})
    end.

send_text(Config, Text) ->
    recv_call(Config, {send_text, Text}).

send(State, Pkt) ->
    {NewID, NewPkt} = case Pkt of
                          #message{id = I} ->
                              ID = id(I),
                              {ID, Pkt#message{id = ID}};
                          #presence{id = I} ->
                              ID = id(I),
                              {ID, Pkt#presence{id = ID}};
                          #iq{id = I} ->
                              ID = id(I),
                              {ID, Pkt#iq{id = ID}};
                          _ ->
                              {undefined, Pkt}
                      end,
    El = xmpp:encode(NewPkt),
    ct:pal("SENT:~n~s~n~s",
	   [format_element(El), xmpp:pp(NewPkt)]),
    Data = case NewPkt of
	       #stream_start{} -> fxml:element_to_header(El);
	       _ -> fxml:element_to_binary(El)
	   end,
    ok = send_text(State, Data),
    NewID.

send_recv(State, #message{} = Msg) ->
    ID = send(State, Msg),
    receive #message{id = ID} = Result -> Result end;
send_recv(State, #presence{} = Pres) ->
    ID = send(State, Pres),
    receive #presence{id = ID} = Result -> Result end;
send_recv(State, #iq{} = IQ) ->
    ID = send(State, IQ),
    receive #iq{id = ID} = Result -> Result end.

sasl_new(<<"PLAIN">>, {User, Server, Password}) ->
    {<<User/binary, $@, Server/binary, 0, User/binary, 0, Password/binary>>,
     fun (_) -> {error, <<"Invalid SASL challenge">>} end};
sasl_new(<<"EXTERNAL">>, {User, Server, _Password}) ->
    {jid:encode(jid:make(User, Server)),
     fun(_) -> ct:fail(sasl_challenge_is_not_expected) end};
sasl_new(<<"ANONYMOUS">>, _) ->
    {<<"">>,
     fun(_) -> ct:fail(sasl_challenge_is_not_expected) end};
sasl_new(<<"DIGEST-MD5">>, {User, Server, Password}) ->
    {<<"">>,
     fun (ServerIn) ->
	     case xmpp_sasl_digest:parse(ServerIn) of
	       bad -> {error, <<"Invalid SASL challenge">>};
	       KeyVals ->
		   Nonce = fxml:get_attr_s(<<"nonce">>, KeyVals),
		   CNonce = id(),
                   Realm = proplists:get_value(<<"realm">>, KeyVals, Server),
		   DigestURI = <<"xmpp/", Realm/binary>>,
		   NC = <<"00000001">>,
		   QOP = <<"auth">>,
		   AuthzId = <<"">>,
		   MyResponse = response(User, Password, Nonce, AuthzId,
					 Realm, CNonce, DigestURI, NC, QOP,
					 <<"AUTHENTICATE">>),
                   SUser = << <<(case Char of
                                     $" -> <<"\\\"">>;
                                     $\\ -> <<"\\\\">>;
                                     _ -> <<Char>>
                                 end)/binary>> || <<Char>> <= User >>,
		   Resp = <<"username=\"", SUser/binary, "\",realm=\"",
			    Realm/binary, "\",nonce=\"", Nonce/binary,
			    "\",cnonce=\"", CNonce/binary, "\",nc=", NC/binary,
			    ",qop=", QOP/binary, ",digest-uri=\"",
			    DigestURI/binary, "\",response=\"",
			    MyResponse/binary, "\"">>,
		   {Resp,
		    fun (ServerIn2) ->
			    case xmpp_sasl_digest:parse(ServerIn2) of
			      bad -> {error, <<"Invalid SASL challenge">>};
			      _KeyVals2 ->
                                    {<<"">>,
                                     fun (_) ->
                                             {error,
                                              <<"Invalid SASL challenge">>}
                                     end}
			    end
		    end}
	     end
     end}.

hex(S) ->
    p1_sha:to_hexlist(S).

response(User, Passwd, Nonce, AuthzId, Realm, CNonce,
	 DigestURI, NC, QOP, A2Prefix) ->
    A1 = case AuthzId of
	   <<"">> ->
	       <<((erlang:md5(<<User/binary, ":", Realm/binary, ":",
				Passwd/binary>>)))/binary,
		 ":", Nonce/binary, ":", CNonce/binary>>;
	   _ ->
	       <<((erlang:md5(<<User/binary, ":", Realm/binary, ":",
				Passwd/binary>>)))/binary,
		 ":", Nonce/binary, ":", CNonce/binary, ":",
		 AuthzId/binary>>
	 end,
    A2 = case QOP of
	   <<"auth">> ->
	       <<A2Prefix/binary, ":", DigestURI/binary>>;
	   _ ->
	       <<A2Prefix/binary, ":", DigestURI/binary,
		 ":00000000000000000000000000000000">>
	 end,
    T = <<(hex((erlang:md5(A1))))/binary, ":", Nonce/binary,
	  ":", NC/binary, ":", CNonce/binary, ":", QOP/binary,
	  ":", (hex((erlang:md5(A2))))/binary>>,
    hex((erlang:md5(T))).

my_jid(Config) ->
    jid:make(?config(user, Config),
	     ?config(server, Config),
	     ?config(resource, Config)).

server_jid(Config) ->
    jid:make(<<>>, ?config(server, Config), <<>>).

pubsub_jid(Config) ->
    Server = ?config(server, Config),
    jid:make(<<>>, <<"pubsub.", Server/binary>>, <<>>).

proxy_jid(Config) ->
    Server = ?config(server, Config),
    jid:make(<<>>, <<"proxy.", Server/binary>>, <<>>).

upload_jid(Config) ->
    Server = ?config(server, Config),
    jid:make(<<>>, <<"upload.", Server/binary>>, <<>>).

muc_jid(Config) ->
    Server = ?config(server, Config),
    jid:make(<<>>, <<"conference.", Server/binary>>, <<>>).

muc_room_jid(Config) ->
    Server = ?config(server, Config),
    jid:make(<<"test">>, <<"conference.", Server/binary>>, <<>>).

my_muc_jid(Config) ->
    Nick = ?config(nick, Config),
    RoomJID = muc_room_jid(Config),
    jid:replace_resource(RoomJID, Nick).

peer_muc_jid(Config) ->
    PeerNick = ?config(peer_nick, Config),
    RoomJID = muc_room_jid(Config),
    jid:replace_resource(RoomJID, PeerNick).

alt_room_jid(Config) ->
    Server = ?config(server, Config),
    jid:make(<<"alt">>, <<"conference.", Server/binary>>, <<>>).

mix_jid(Config) ->
    Server = ?config(server, Config),
    jid:make(<<>>, <<"mix.", Server/binary>>, <<>>).

mix_room_jid(Config) ->
    Server = ?config(server, Config),
    jid:make(<<"test">>, <<"mix.", Server/binary>>, <<>>).

id() ->
    id(<<>>).

id(<<>>) ->
    p1_rand:get_string();
id(ID) ->
    ID.

get_features(Config) ->
    get_features(Config, server_jid(Config)).

get_features(Config, To) ->
    ct:comment("Getting features of ~s", [jid:encode(To)]),
    #iq{type = result, sub_els = [#disco_info{features = Features}]} =
        send_recv(Config, #iq{type = get, sub_els = [#disco_info{}], to = To}),
    Features.

is_feature_advertised(Config, Feature) ->
    is_feature_advertised(Config, Feature, server_jid(Config)).

is_feature_advertised(Config, Feature, To) ->
    Features = get_features(Config, To),
    lists:member(Feature, Features).

set_opt(Opt, Val, Config) ->
    [{Opt, Val}|lists:keydelete(Opt, 1, Config)].

wait_for_master(Config) ->
    put_event(Config, peer_ready),
    case get_event(Config) of
	peer_ready ->
	    ok;
	Other ->
	    suite:match_failure(Other, peer_ready)
    end.

wait_for_slave(Config) ->
    put_event(Config, peer_ready),
    case get_event(Config) of
	peer_ready ->
	    ok;
	Other ->
	    suite:match_failure(Other, peer_ready)
    end.

make_iq_result(#iq{from = From} = IQ) ->
    IQ#iq{type = result, to = From, from = undefined, sub_els = []}.

self_presence(Config, Type) ->
    MyJID = my_jid(Config),
    ct:comment("Sending self-presence"),
    #presence{type = Type, from = MyJID} =
	send_recv(Config, #presence{type = Type}).

set_roster(Config, Subscription, Groups) ->
    MyJID = my_jid(Config),
    {U, S, _} = jid:tolower(MyJID),
    PeerJID = ?config(peer, Config),
    PeerBareJID = jid:remove_resource(PeerJID),
    PeerLJID = jid:tolower(PeerBareJID),
    ct:comment("Adding ~s to roster with subscription '~s' in groups ~p",
	       [jid:encode(PeerBareJID), Subscription, Groups]),
    {atomic, _} = mod_roster:set_roster(#roster{usj = {U, S, PeerLJID},
						us = {U, S},
						jid = PeerLJID,
						subscription = Subscription,
						groups = Groups}),
    Config.

del_roster(Config) ->
    del_roster(Config, ?config(peer, Config)).

del_roster(Config, PeerJID) ->
    MyJID = my_jid(Config),
    {U, S, _} = jid:tolower(MyJID),
    PeerBareJID = jid:remove_resource(PeerJID),
    PeerLJID = jid:tolower(PeerBareJID),
    ct:comment("Removing ~s from roster", [jid:encode(PeerBareJID)]),
    {atomic, _} = mod_roster:del_roster(U, S, PeerLJID),
    Config.

get_roster(Config) ->
    {LUser, LServer, _} = jid:tolower(my_jid(Config)),
    mod_roster:get_roster(LUser, LServer).

recv_call(Config, Msg) ->
    Receiver = ?config(receiver, Config),
    Ref = make_ref(),
    Receiver ! {Ref, Msg},
    receive
	{Ref, Reply} ->
	    Reply
    end.

start_receiver(NS, Owner, Server, Port) ->
    MRef = erlang:monitor(process, Owner),
    {ok, Socket} = xmpp_socket:connect(
		     Server, Port,
		     [binary, {packet, 0}, {active, false}], infinity),
    receiver(NS, Owner, Socket, MRef).

receiver(NS, Owner, Socket, MRef) ->
    receive
	{Ref, reset_stream} ->
	    Socket1 = xmpp_socket:reset_stream(Socket),
	    Owner ! {Ref, ok},
	    receiver(NS, Owner, Socket1, MRef);
	{Ref, {starttls, Certfile}} ->
	    {ok, TLSSocket} = xmpp_socket:starttls(
				Socket,
				[{certfile, Certfile}, connect]),
	    Owner ! {Ref, ok},
	    receiver(NS, Owner, TLSSocket, MRef);
	{Ref, compress} ->
	    {ok, ZlibSocket} = xmpp_socket:compress(Socket),
	    Owner ! {Ref, ok},
	    receiver(NS, Owner, ZlibSocket, MRef);
	{Ref, {send_text, Text}} ->
	    Ret = xmpp_socket:send(Socket, Text),
	    Owner ! {Ref, Ret},
	    receiver(NS, Owner, Socket, MRef);
	{Ref, close} ->
	    xmpp_socket:close(Socket),
	    Owner ! {Ref, ok},
	    receiver(NS, Owner, Socket, MRef);
        {'$gen_event', {xmlstreamelement, El}} ->
	    Owner ! decode_stream_element(NS, El),
	    receiver(NS, Owner, Socket, MRef);
	{'$gen_event', {xmlstreamstart, Name, Attrs}} ->
	    Owner ! decode(#xmlel{name = Name, attrs = Attrs}, <<>>, []),
	    receiver(NS, Owner, Socket, MRef);
	{'$gen_event', Event} ->
            Owner ! Event,
	    receiver(NS, Owner, Socket, MRef);
	{'DOWN', MRef, process, Owner, _} ->
	    ok;
	{tcp, _, Data} ->
	    case xmpp_socket:recv(Socket, Data) of
		{ok, Socket1} ->
		    receiver(NS, Owner, Socket1, MRef);
		{error, _} ->
		    Owner ! closed,
		    receiver(NS, Owner, Socket, MRef)
	    end;
	{tcp_error, _, _} ->
	    Owner ! closed,
	    receiver(NS, Owner, Socket, MRef);
	{tcp_closed, _} ->
	    Owner ! closed,
	    receiver(NS, Owner, Socket, MRef)
    end.

%%%===================================================================
%%% Clients puts and gets events via this relay.
%%%===================================================================
start_event_relay() ->
    spawn(fun event_relay/0).

stop_event_relay(Config) ->
    Pid = ?config(event_relay, Config),
    exit(Pid, normal).

event_relay() ->
    event_relay([], []).

event_relay(Events, Subscribers) ->
    receive
        {subscribe, From} ->
	    erlang:monitor(process, From),
            From ! {ok, self()},
            lists:foreach(
              fun(Event) -> From ! {event, Event, self()}
              end, Events),
            event_relay(Events, [From|Subscribers]);
        {put, Event, From} ->
            From ! {ok, self()},
            lists:foreach(
              fun(Pid) when Pid /= From ->
                      Pid ! {event, Event, self()};
                 (_) ->
                      ok
              end, Subscribers),
            event_relay([Event|Events], Subscribers);
	{'DOWN', _MRef, process, Pid, _Info} ->
	    case lists:member(Pid, Subscribers) of
		true ->
		    NewSubscribers = lists:delete(Pid, Subscribers),
		    lists:foreach(
		      fun(Subscriber) ->
			      Subscriber ! {event, peer_down, self()}
		      end, NewSubscribers),
		    event_relay(Events, NewSubscribers);
		false ->
		    event_relay(Events, Subscribers)
	    end
    end.

subscribe_to_events(Config) ->
    Relay = ?config(event_relay, Config),
    Relay ! {subscribe, self()},
    receive
        {ok, Relay} ->
            ok
    end.

put_event(Config, Event) ->
    Relay = ?config(event_relay, Config),
    Relay ! {put, Event, self()},
    receive
        {ok, Relay} ->
            ok
    end.

get_event(Config) ->
    Relay = ?config(event_relay, Config),
    receive
        {event, Event, Relay} ->
            Event
    end.

flush(Config) ->
    receive
	{event, peer_down, _} -> flush(Config);
	closed -> flush(Config);
	Msg -> ct:fail({unexpected_msg, Msg})
    after 0 ->
	    ok
    end.