cttest

%%%-------------------------------------------------------------------
%%%
%%% Copyright (C) 2002-2021 ProcessOne, SARL. 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.
%%%
%%%-------------------------------------------------------------------
-module(xmpp_stream_pkix).

%% API
-export([authenticate/1, authenticate/2, get_cert_domains/1, format_error/1]).

-include("xmpp.hrl").
-include_lib("public_key/include/public_key.hrl").
-include("XmppAddr.hrl").

-type cert() :: #'OTPCertificate'{}.

%%%===================================================================
%%% API
%%%===================================================================
-spec authenticate(xmpp_stream_in:state() | xmpp_stream_out:state())
      -> {ok, binary()} | {error, atom(), binary()}.
authenticate(State) ->
    authenticate(State, <<"">>).

-spec authenticate(xmpp_stream_in:state() | xmpp_stream_out:state(), binary())
      -> {ok, binary()} | {error, atom(), binary()}.
authenticate(#{xmlns := ?NS_SERVER,
	       socket := Socket} = State, Authzid) ->
    Peer = maps:get(remote_server, State, Authzid),
    case verify_server_cert(Peer, Socket) of
	ok ->
	    {ok, Peer};
	{error, Reason} ->
	    {error, Reason, Peer}
    end;
authenticate(#{xmlns := ?NS_CLIENT, stream_direction := out,
	       socket := Socket, server := Server}, _) ->
    case verify_server_cert(Server, Socket) of
	ok ->
	    {ok, Server};
	{error, Reason} ->
	    {error, Reason, Server}
    end;
authenticate(#{xmlns := ?NS_CLIENT, stream_direction := in,
	       socket := Socket, server := Server}, Authzid) ->
    JID = try jid:decode(Authzid)
	  catch _:{bad_jid, <<>>} -> jid:make(Server);
		_:{bad_jid, _} -> {error, invalid_authzid, Authzid}
	  end,
    case JID of
	#jid{user = User, lserver = LServer} ->
	    case verify_cert(Socket) of
		{ok, Cert} ->
		    JIDs = get_xmpp_addrs(Cert),
		    get_username(JID, JIDs, LServer);
		{error, Reason} ->
		    {error, Reason, User}
	    end;
	Err ->
	    Err
    end.

format_error(idna_failed) ->
    {'not-authorized', <<"Remote domain is not an IDN hostname">>};
format_error(hostname_mismatch) ->
    {'not-authorized', <<"Certificate host name mismatch">>};
format_error(jid_mismatch) ->
    {'not-authorized', <<"Certificate JID mismatch">>};
format_error(get_cert_failed) ->
    {'not-authorized', <<"Failed to get peer certificate">>};
format_error(invalid_authzid) ->
    {'invalid-authzid', <<"Malformed JID">>};
format_error(Other) ->
    {'not-authorized', erlang:atom_to_binary(Other, utf8)}.

-spec get_cert_domains(cert()) -> [binary()].
get_cert_domains(Cert) ->
    TBSCert = Cert#'OTPCertificate'.tbsCertificate,
    {rdnSequence, Subject} = TBSCert#'OTPTBSCertificate'.subject,
    Extensions = TBSCert#'OTPTBSCertificate'.extensions,
    get_domain_from_subject(lists:flatten(Subject)) ++
	get_domains_from_san(Extensions).

%%%===================================================================
%%% Internal functions
%%%===================================================================
-spec verify_server_cert(binary(), xmpp_socket:socket()) -> ok | {error, atom()}.
verify_server_cert(Server, Socket) ->
    case verify_cert(Socket) of
	{ok, Cert} ->
	    try list_to_binary(idna:utf8_to_ascii(Server)) of
		AsciiServer ->
		    case lists:any(
			   fun(D) -> match_domain(AsciiServer, D) end,
			   get_cert_domains(Cert)) of
			true ->
			    ok;
			false ->
			    {error, hostname_mismatch}
		    end
	    catch _:_ ->
		    {error, idna_failed}
	    end;
	{error, _} = Err ->
	    Err
    end.

-spec verify_cert(xmpp_socket:socket()) -> {ok, cert()} | {error, atom()}.
verify_cert(Socket) ->
    case xmpp_socket:get_peer_certificate(Socket, otp) of
	{ok, Cert} ->
	    case xmpp_socket:get_verify_result(Socket) of
		0 ->
		    {ok, Cert};
		VerifyRes ->
		    %% TODO: return atomic errors
		    %% This should be improved in fast_tls
		    Reason = fast_tls:get_cert_verify_string(VerifyRes, Cert),
		    {error, erlang:binary_to_atom(Reason, utf8)}
	    end;
	error ->
	    {error, get_cert_failed}
    end.

-spec get_domain_from_subject([#'AttributeTypeAndValue'{}]) -> [binary()].
get_domain_from_subject(AttrVals) ->
    case lists:keyfind(?'id-at-commonName',
		       #'AttributeTypeAndValue'.type,
		       AttrVals) of
	#'AttributeTypeAndValue'{value = {_, S}} ->
	    try jid:decode(iolist_to_binary(S)) of
		#jid{luser = <<"">>, lresource = <<"">>, lserver = Domain} ->
		    [Domain];
		_ ->
		    []
	    catch _:{bad_jid, _} ->
		    []
	    end;
	_ ->
	    []
    end.

-spec get_domains_from_san([#'Extension'{}] | asn1_NOVALUE) -> [binary()].
get_domains_from_san(Extensions) when is_list(Extensions) ->
    case lists:keyfind(?'id-ce-subjectAltName',
		       #'Extension'.extnID,
		       Extensions) of
	#'Extension'{extnValue = Vals} ->
	    lists:flatmap(
	      fun({dNSName, S}) ->
		      [iolist_to_binary(S)];
		 ({otherName, AnotherName}) ->
		      case decode_xmpp_addr(AnotherName) of
			  {ok, #jid{luser = <<"">>,
				    lresource = <<"">>,
				    lserver = Domain}} ->
			      try list_to_binary(idna:utf8_to_ascii(Domain))
			      catch _:_ -> []
			      end;
			  _ ->
			      []
		      end;
		 (_) ->
		      []
	      end, Vals);
	_ ->
	    []
    end;
get_domains_from_san(_) ->
    [].

-spec decode_xmpp_addr(#'AnotherName'{}) -> {ok, jid()} | error.
decode_xmpp_addr(#'AnotherName'{'type-id' = ?'id-on-xmppAddr',
				value = XmppAddr}) ->
    try 'XmppAddr':decode('XmppAddr', XmppAddr) of
	{ok, JIDStr} ->
	    try {ok, jid:decode(iolist_to_binary(JIDStr))}
	    catch _:{bad_jid, _} -> error
	    end;
	_ ->
	    error
    catch _:_ ->
	    error
    end;
decode_xmpp_addr(_) ->
    error.

-spec get_xmpp_addrs(cert()) -> [jid()].
get_xmpp_addrs(Cert) ->
    TBSCert = Cert#'OTPCertificate'.tbsCertificate,
    case TBSCert#'OTPTBSCertificate'.extensions of
	Extensions when is_list(Extensions) ->
	    case lists:keyfind(?'id-ce-subjectAltName',
			       #'Extension'.extnID,
			       Extensions) of
		#'Extension'{extnValue = Vals} ->
		    lists:flatmap(
		      fun({otherName, AnotherName}) ->
			      case decode_xmpp_addr(AnotherName) of
				  {ok, JID} -> [JID];
				  _ -> []
			      end;
			 (_) ->
			      []
		      end, Vals);
		_ ->
		    []
	    end;
	_ ->
	    []
    end.

-spec get_username(jid(), [jid()], binary()) ->
			  {ok, binary()} | {error, jid_mismatch, binary()}.
get_username(#jid{user = User, lserver = LS}, _, LServer) when LS /= LServer ->
    %% The user provided JID from different domain
    {error, jid_mismatch, User};
get_username(#jid{user = <<>>}, [#jid{user = U, lserver = LS}], LServer)
  when U /= <<>> andalso LS == LServer ->
    %% The user didn't provide JID or username, and there is only
    %% one 'non-global' JID matching current domain
    {ok, U};
get_username(#jid{user = User}, [], _) when User /= <<>> ->
    %% The user provided username, but the certificate contains no JIDs
    %% We accept this since the certificate is verified
    {ok, User};
get_username(#jid{user = User, luser = LUser}, JIDs, LServer) when User /= <<>> ->
    %% The user provided username
    lists:foldl(
      fun(_, {ok, _} = OK) ->
	      OK;
	 (#jid{user = <<>>, lserver = LS}, _) when LS == LServer ->
	      %% Found "global" JID in the certificate
	      %% (i.e. in the form of 'domain.com')
	      %% within current domain, so we force matching
	      {ok, User};
	 (#jid{luser = LU, lserver = LS}, _) when LU == LUser, LS == LServer ->
	      %% Found exact JID matching
	      {ok, User};
	 (_, Err) ->
	      Err
      end, {error, jid_mismatch, User}, JIDs);
get_username(#jid{user = User}, _, _) ->
    %% Nothing from above is true
    {error, jid_mismatch, User}.

-spec match_domain(binary(), binary()) -> boolean().
match_domain(Domain, Domain) -> true;
match_domain(Domain, <<"*.", Rest/binary>>) ->
    %% RFC6120 states:
    %% DNS domain names in server certificates MAY contain the wildcard
    %% character '*' as the complete left-most label within the identifier
    case binary:split(Domain, <<$.>>) of
	[_, Rest] -> true;
	_ -> false
    end;
match_domain(_, _) ->
    false.