xmpp.chapril.org-ejabberd/src/eldap.erl

-module(eldap).
%%% --------------------------------------------------------------------
%%% Created:  12 Oct 2000 by Tobbe <tnt@home.se>
%%% Function: Erlang client LDAP implementation according RFC 2251.
%%%           The interface is based on RFC 1823, and
%%%           draft-ietf-asid-ldap-c-api-00.txt
%%%
%%% Copyright (C) 2000  Torbjorn Tornkvist, tnt@home.se
%%%
%%%
%%% 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.

%%% Modified by Sean Hinde <shinde@iee.org> 7th Dec 2000
%%% Turned into gen_fsm, made non-blocking, added timers etc to support this.
%%% Now has the concept of a name (string() or atom()) per instance which allows
%%% multiple users to call by name if so desired.
%%%
%%% Can be configured with start_link parameters or use a config file to get
%%% host to connect to, dn, password, log function etc.

%%% Modified by Alexey Shchepin <alexey@sevcom.net>

%%% Modified by Evgeniy Khramtsov <ekhramtsov@process-one.net>
%%% Implemented queue for bind() requests to prevent pending binds.
%%% Implemented extensibleMatch/2 function.
%%% Implemented LDAP Extended Operations (currently only Password Modify
%%%   is supported - RFC 3062).

%%% Modified by Christophe Romain <christophe.romain@process-one.net>
%%% Improve error case handling

%%% Modified by Mickael Remond <mremond@process-one.net>
%%% Now use ejabberd log mechanism

%%% Modified by:
%%%   Thomas Baden <roo@ham9.net> 2008 April 6th
%%%   Andy Harb <Ahmad.N.Abou-Harb@jpl.nasa.gov> 2008 April 28th
%%%   Anton Podavalov <a.podavalov@gmail.com> 2009 February 22th
%%% Added LDAPS support, modeled off jungerl eldap.erl version.
%%% NOTICE: STARTTLS is not supported.

%%% --------------------------------------------------------------------
-vc('$Id$ ').

%%%----------------------------------------------------------------------
%%% LDAP Client state machine.
%%% Possible states are:
%%%     connecting - actually disconnected, but retrying periodically
%%%     wait_bind_response  - connected and sent bind request
%%%     active - bound to LDAP Server and ready to handle commands
%%%     active_bind - sent bind() request and waiting for response
%%%----------------------------------------------------------------------

-behaviour(p1_fsm).

-include("logger.hrl").

%% External exports
-export([start_link/1, start_link/6]).

-export([baseObject/0, singleLevel/0, wholeSubtree/0,
	 close/1, equalityMatch/2, greaterOrEqual/2,
	 lessOrEqual/2, approxMatch/2, search/2, substrings/2,
	 present/1, extensibleMatch/2, 'and'/1, 'or'/1, 'not'/1,
	 modify/3, mod_add/2, mod_delete/2, mod_replace/2, add/3,
	 delete/2, modify_dn/5, modify_passwd/3, bind/3]).

-export([get_status/1]).

-export([init/1, connecting/2, connecting/3,
	 wait_bind_response/3, active/3, active_bind/3,
	 handle_event/3, handle_sync_event/4, handle_info/3,
	 terminate/3, code_change/4]).

-export_type([filter/0]).

-include("ELDAPv3.hrl").
-include_lib("kernel/include/inet.hrl").
-include("eldap.hrl").

-define(LDAP_VERSION, 3).

-define(RETRY_TIMEOUT, 500).

-define(BIND_TIMEOUT, 10000).

-define(CMD_TIMEOUT, 100000).
%% Used in gen_fsm sync calls.
%% Used as a timeout for gen_tcp:send/2

-define(CALL_TIMEOUT,
	(?CMD_TIMEOUT) + (?BIND_TIMEOUT) + (?RETRY_TIMEOUT)).

-define(SEND_TIMEOUT, 30000).

-define(MAX_TRANSACTION_ID, 65535).

-define(MIN_TRANSACTION_ID, 0).
%% Grace period after "soft" LDAP bind errors:

-define(GRACEFUL_RETRY_TIMEOUT, 5000).

-define(SUPPORTEDEXTENSION,
	<<"1.3.6.1.4.1.1466.101.120.7">>).

-define(SUPPORTEDEXTENSIONSYNTAX,
	<<"1.3.6.1.4.1.1466.115.121.1.38">>).

-define(STARTTLS, <<"1.3.6.1.4.1.1466.20037">>).

-type handle() :: pid() | atom() | binary().

-record(eldap,
	{version = ?LDAP_VERSION :: non_neg_integer(),
         hosts = []              :: [binary()],
         host = undefined        :: binary() | undefined,
	 port = 389              :: inet:port_number(),
         sockmod = gen_tcp       :: ssl | gen_tcp,
         tls = none              :: none | tls,
         tls_options = []        :: [{certfile, string()} |
				     {cacertfile, string()} |
                                     {depth, non_neg_integer()} |
                                     {verify, non_neg_integer()} |
                                     {fail_if_no_peer_cert, boolean()}],
	 fd                      :: gen_tcp:socket() | undefined,
         rootdn = <<"">>         :: binary(),
         passwd = <<"">>         :: binary(),
         id = 0                  :: non_neg_integer(),
         bind_timer = make_ref() :: reference(),
	 dict = dict:new()       :: dict:dict(),
         req_q = queue:new()     :: queue:queue()}).

%%%----------------------------------------------------------------------
%%% API
%%%----------------------------------------------------------------------
start_link(Name) ->
    Reg_name = misc:binary_to_atom(<<"eldap_",
				       Name/binary>>),
    p1_fsm:start_link({local, Reg_name}, ?MODULE, [], []).

-spec start_link(binary(), [binary()], inet:port_number(), binary(),
                 binary(), tlsopts()) -> any().

start_link(Name, Hosts, Port, Rootdn, Passwd, Opts) ->
    Reg_name = misc:binary_to_atom(<<"eldap_",
				       Name/binary>>),
    p1_fsm:start_link({local, Reg_name}, ?MODULE,
		       [Hosts, Port, Rootdn, Passwd, Opts], []).

-spec get_status(handle()) -> any().

%%% --------------------------------------------------------------------
%%% Get status of connection.
%%% --------------------------------------------------------------------
get_status(Handle) ->
    Handle1 = get_handle(Handle),
    p1_fsm:sync_send_all_state_event(Handle1, get_status).

%%% --------------------------------------------------------------------
%%% Shutdown connection (and process) asynchronous.
%%% --------------------------------------------------------------------
-spec close(handle()) -> any().

close(Handle) ->
    Handle1 = get_handle(Handle),
    p1_fsm:send_all_state_event(Handle1, close).

%%% --------------------------------------------------------------------
%%% Add an entry. The entry field MUST NOT exist for the AddRequest
%%% to succeed. The parent of the entry MUST exist.
%%% Example:
%%%
%%%  add(Handle,
%%%         "cn=Bill Valentine, ou=people, o=Bluetail AB, dc=bluetail, dc=com",
%%%         [{"objectclass", ["person"]},
%%%          {"cn", ["Bill Valentine"]},
%%%          {"sn", ["Valentine"]},
%%%          {"telephoneNumber", ["545 555 00"]}]
%%%     )
%%% --------------------------------------------------------------------
add(Handle, Entry, Attributes) ->
    Handle1 = get_handle(Handle),
    p1_fsm:sync_send_event(Handle1,
			    {add, Entry, add_attrs(Attributes)}, ?CALL_TIMEOUT).

%%% Do sanity check !
add_attrs(Attrs) ->
    F = fun ({Type, Vals}) ->
		{'AddRequest_attributes', Type, Vals}
	end,
    case catch lists:map(F, Attrs) of
      {'EXIT', _} -> throw({error, attribute_values});
      Else -> Else
    end.

%%% --------------------------------------------------------------------
%%% Delete an entry. The entry consists of the DN of
%%% the entry to be deleted.
%%% Example:
%%%
%%%  delete(Handle,
%%%         "cn=Bill Valentine, ou=people, o=Bluetail AB, dc=bluetail, dc=com"
%%%        )
%%% --------------------------------------------------------------------
delete(Handle, Entry) ->
    Handle1 = get_handle(Handle),
    p1_fsm:sync_send_event(Handle1, {delete, Entry},
			    ?CALL_TIMEOUT).

%%% --------------------------------------------------------------------
%%% Modify an entry. Given an entry a number of modification
%%% operations can be performed as one atomic operation.
%%% Example:
%%%
%%%  modify(Handle,
%%%         "cn=Torbjorn Tornkvist, ou=people, o=Bluetail AB, dc=bluetail, dc=com",
%%%         [replace("telephoneNumber", ["555 555 00"]),
%%%          add("description", ["LDAP hacker"])]
%%%        )
%%% --------------------------------------------------------------------
-spec modify(handle(), any(), [add | delete | replace]) -> any().

modify(Handle, Object, Mods) ->
    Handle1 = get_handle(Handle),
    p1_fsm:sync_send_event(Handle1, {modify, Object, Mods},
			    ?CALL_TIMEOUT).

%%%
%%% Modification operations.
%%% Example:
%%%            replace("telephoneNumber", ["555 555 00"])
%%%
mod_add(Type, Values) ->
    m(add, Type, Values).

mod_delete(Type, Values) ->
    m(delete, Type, Values).

%%% --------------------------------------------------------------------
%%% Modify an entry. Given an entry a number of modification
%%% operations can be performed as one atomic operation.
%%% Example:
%%%
%%%  modify_dn(Handle,
%%%    "cn=Bill Valentine, ou=people, o=Bluetail AB, dc=bluetail, dc=com",
%%%    "cn=Ben Emerson",
%%%    true,
%%%    ""
%%%        )
%%% --------------------------------------------------------------------
mod_replace(Type, Values) ->
    m(replace, Type, Values).

m(Operation, Type, Values) ->
    #'ModifyRequest_modification_SEQOF'{operation =
					    Operation,
					modification =
					    #'AttributeTypeAndValues'{type =
									  Type,
								      vals =
									  Values}}.

modify_dn(Handle, Entry, NewRDN, DelOldRDN, NewSup) ->
    Handle1 = get_handle(Handle),
    p1_fsm:sync_send_event(Handle1,
			    {modify_dn, Entry, NewRDN, bool_p(DelOldRDN),
			     optional(NewSup)},
			    ?CALL_TIMEOUT).

-spec modify_passwd(handle(), binary(), binary()) -> any().

modify_passwd(Handle, DN, Passwd) ->
    Handle1 = get_handle(Handle),
    p1_fsm:sync_send_event(Handle1,
			    {modify_passwd, DN, Passwd}, ?CALL_TIMEOUT).

%%% --------------------------------------------------------------------
%%% Bind.
%%% Example:
%%%
%%%  bind(Handle,
%%%    "cn=Bill Valentine, ou=people, o=Bluetail AB, dc=bluetail, dc=com",
%%%    "secret")
%%% --------------------------------------------------------------------
-spec bind(handle(), binary(), binary()) -> any().

bind(Handle, RootDN, Passwd) ->
    Handle1 = get_handle(Handle),
    p1_fsm:sync_send_event(Handle1, {bind, RootDN, Passwd},
			    ?CALL_TIMEOUT).

%%% Sanity checks !

bool_p(Bool) when Bool == true; Bool == false -> Bool.

optional([]) -> asn1_NOVALUE;
optional(Value) -> Value.

%%% --------------------------------------------------------------------
%%% Synchronous search of the Directory returning a
%%% requested set of attributes.
%%%
%%%  Example:
%%%
%%%	Filter = eldap:substrings("sn", [{any,"o"}]),
%%%	eldap:search(S, [{base, "dc=bluetail, dc=com"},
%%%	                 {filter, Filter},
%%%			 {attributes,["cn"]}])),
%%%
%%% Returned result:  {ok, #eldap_search_result{}}
%%%
%%% Example:
%%%
%%%  {ok,{eldap_search_result,
%%%        [{eldap_entry,
%%%           "cn=Magnus Froberg, dc=bluetail, dc=com",
%%%           [{"cn",["Magnus Froberg"]}]},
%%%         {eldap_entry,
%%%           "cn=Torbjorn Tornkvist, dc=bluetail, dc=com",
%%%           [{"cn",["Torbjorn Tornkvist"]}]}],
%%%        []}}
%%%
%%% --------------------------------------------------------------------
-type search_args() :: [{base, binary()} |
                        {filter, filter()} |
                        {scope, scope()} |
                        {attributes, [binary()]} |
                        {types_only, boolean()} |
                        {timeout, non_neg_integer()} |
                        {limit, non_neg_integer()} |
                        {deref_aliases, never | searching | finding | always}].

-spec search(handle(), eldap_search() | search_args()) -> any().

search(Handle, A) when is_record(A, eldap_search) ->
    call_search(Handle, A);
search(Handle, L) when is_list(L) ->
    case catch parse_search_args(L) of
      {error, Emsg} -> {error, Emsg};
      {'EXIT', Emsg} -> {error, Emsg};
      A when is_record(A, eldap_search) ->
	  call_search(Handle, A)
    end.

call_search(Handle, A) ->
    Handle1 = get_handle(Handle),
    p1_fsm:sync_send_event(Handle1, {search, A},
			    ?CALL_TIMEOUT).

-spec parse_search_args(search_args()) -> eldap_search().

parse_search_args(Args) ->
    parse_search_args(Args,
		      #eldap_search{scope = wholeSubtree}).

parse_search_args([{base, Base} | T], A) ->
    parse_search_args(T, A#eldap_search{base = Base});
parse_search_args([{filter, Filter} | T], A) ->
    parse_search_args(T, A#eldap_search{filter = Filter});
parse_search_args([{scope, Scope} | T], A) ->
    parse_search_args(T, A#eldap_search{scope = Scope});
parse_search_args([{attributes, Attrs} | T], A) ->
    parse_search_args(T,
		      A#eldap_search{attributes = Attrs});
parse_search_args([{types_only, TypesOnly} | T], A) ->
    parse_search_args(T,
		      A#eldap_search{types_only = TypesOnly});
parse_search_args([{timeout, Timeout} | T], A)
    when is_integer(Timeout) ->
    parse_search_args(T, A#eldap_search{timeout = Timeout});
parse_search_args([{limit, Limit} | T], A)
    when is_integer(Limit) ->
    parse_search_args(T, A#eldap_search{limit = Limit});
parse_search_args([{deref_aliases, never} | T], A) ->
    parse_search_args(T,
		      A#eldap_search{deref_aliases = neverDerefAliases});
parse_search_args([{deref_aliases, searching} | T],
		  A) ->
    parse_search_args(T,
		      A#eldap_search{deref_aliases = derefInSearching});
parse_search_args([{deref_aliases, finding} | T], A) ->
    parse_search_args(T,
		      A#eldap_search{deref_aliases = derefFindingBaseObj});
parse_search_args([{deref_aliases, always} | T], A) ->
    parse_search_args(T,
		      A#eldap_search{deref_aliases = derefAlways});
parse_search_args([H | _], _) ->
    throw({error, {unknown_arg, H}});
parse_search_args([], A) -> A.

baseObject() -> baseObject.

singleLevel() -> singleLevel.

%%%
%%% The Scope parameter
%%%
wholeSubtree() -> wholeSubtree.

%%%
%%% Boolean filter operations
%%%
-type filter() :: 'and'() | 'or'() | 'not'() | equalityMatch() |
                  greaterOrEqual() | lessOrEqual() | approxMatch() |
                  present() | substrings() | extensibleMatch().

%%%
%%% The following Filter parameters consist of an attribute
%%% and an attribute value. Example: F("uid","tobbe")
%%%
-type 'and'() :: {'and', [filter()]}.
-spec 'and'([filter()]) -> 'and'().

'and'(ListOfFilters) when is_list(ListOfFilters) ->
    {'and', ListOfFilters}.

-type 'or'() :: {'or', [filter()]}.
-spec 'or'([filter()]) -> 'or'().

'or'(ListOfFilters) when is_list(ListOfFilters) ->
    {'or', ListOfFilters}.

-type 'not'() :: {'not', filter()}.
-spec 'not'(filter()) -> 'not'().

'not'(Filter) when is_tuple(Filter) -> {'not', Filter}.

-type equalityMatch() :: {equalityMatch, 'AttributeValueAssertion'()}.
-spec equalityMatch(binary(), binary()) -> equalityMatch().

equalityMatch(Desc, Value) ->
    {equalityMatch, av_assert(Desc, Value)}.

-type greaterOrEqual() :: {greaterOrEqual, 'AttributeValueAssertion'()}.
-spec greaterOrEqual(binary(), binary()) -> greaterOrEqual().

greaterOrEqual(Desc, Value) ->
    {greaterOrEqual, av_assert(Desc, Value)}.

-type lessOrEqual() :: {lessOrEqual, 'AttributeValueAssertion'()}.
-spec lessOrEqual(binary(), binary()) -> lessOrEqual().

lessOrEqual(Desc, Value) ->
    {lessOrEqual, av_assert(Desc, Value)}.

-type approxMatch() :: {approxMatch, 'AttributeValueAssertion'()}.
-spec approxMatch(binary(), binary()) -> approxMatch().

approxMatch(Desc, Value) ->
    {approxMatch, av_assert(Desc, Value)}.

-type 'AttributeValueAssertion'() ::
        #'AttributeValueAssertion'{attributeDesc :: binary(),
                                   assertionValue :: binary()}.

-spec av_assert(binary(), binary()) -> 'AttributeValueAssertion'().

av_assert(Desc, Value) ->
    #'AttributeValueAssertion'{attributeDesc = Desc,
			       assertionValue = Value}.

%%%
%%% Filter to check for the presence of an attribute
%%%
-type present() :: {present, binary()}.
-spec present(binary()) -> present().

%%%
%%% A substring filter seem to be based on a pattern:
%%%
%%%   InitValue*AnyValue*FinalValue
%%%
%%% where all three parts seem to be optional (at least when
%%% talking with an OpenLDAP server). Thus, the arguments
%%% to substrings/2 looks like this:
%%%
%%% Type   ::= string( <attribute> )
%%% SubStr ::= listof( {initial,Value} | {any,Value}, {final,Value})
%%%
%%% Example: substrings("sn",[{initial,"To"},{any,"kv"},{final,"st"}])
%%% will match entries containing:  'sn: Tornkvist'
%%%
present(Attribute) ->
    {present, Attribute}.

%%%
%%% extensibleMatch filter.
%%% FIXME: Describe the purpose of this filter.
%%%
%%% Value   ::= string( <attribute> )
%%% Opts    ::= listof( {matchingRule, Str} | {type, Str} | {dnAttributes, true} )
%%%
%%% Example: extensibleMatch("Fred", [{matchingRule, "1.2.3.4.5"}, {type, "cn"}]).
%%%
-type substr() :: [{initial | any | final, binary()}].
-type 'SubstringFilter'() ::
        #'SubstringFilter'{type :: binary(),
                           substrings :: substr()}.

-type substrings() :: {substrings, 'SubstringFilter'()}.
-spec substrings(binary(), substr()) -> substrings().

substrings(Type, SubStr) ->
    {substrings,
     #'SubstringFilter'{type = Type, substrings = SubStr}}.

-type match_opts() :: [{matchingRule | type, binary()} |
                       {dnAttributes, boolean()}].

-type 'MatchingRuleAssertion'() ::
        #'MatchingRuleAssertion'{matchValue :: binary(),
                                 type :: asn1_NOVALUE | binary(),
                                 matchingRule :: asn1_NOVALUE | binary(),
                                 dnAttributes :: asn1_DEFAULT | true}.

-type extensibleMatch() :: {extensibleMatch, 'MatchingRuleAssertion'()}.
-spec extensibleMatch(binary(), match_opts()) -> extensibleMatch().

extensibleMatch(Value, Opts) ->
    MRA = #'MatchingRuleAssertion'{matchValue = Value},
    {extensibleMatch, extensibleMatch_opts(Opts, MRA)}.

extensibleMatch_opts([{matchingRule, Rule} | Opts], MRA) ->
    extensibleMatch_opts(Opts,
			 MRA#'MatchingRuleAssertion'{matchingRule = Rule});
extensibleMatch_opts([{type, Desc} | Opts], MRA) ->
    extensibleMatch_opts(Opts,
			 MRA#'MatchingRuleAssertion'{type = Desc});
extensibleMatch_opts([{dnAttributes, true} | Opts],
		     MRA) ->
    extensibleMatch_opts(Opts,
			 MRA#'MatchingRuleAssertion'{dnAttributes = true});
extensibleMatch_opts([_ | Opts], MRA) ->
    extensibleMatch_opts(Opts, MRA);
extensibleMatch_opts([], MRA) -> MRA.

get_handle(Pid) when is_pid(Pid) -> Pid;
get_handle(Atom) when is_atom(Atom) -> Atom;
get_handle(Name) when is_binary(Name) ->
    misc:binary_to_atom(<<"eldap_",
			    Name/binary>>).

%%%----------------------------------------------------------------------
%%% Callback functions from gen_fsm
%%%----------------------------------------------------------------------

%%----------------------------------------------------------------------
%% Func: init/1
%% Returns: {ok, StateName, StateData}          |
%%          {ok, StateName, StateData, Timeout} |
%%          ignore                              |
%%          {stop, StopReason}
%% I use the trick of setting a timeout of 0 to pass control into the
%% process.
%%----------------------------------------------------------------------
init([Hosts, Port, Rootdn, Passwd, Opts]) ->
    Encrypt = case proplists:get_value(encrypt, Opts) of
                  tls -> tls;
                  _ -> none
	      end,
    PortTemp = case Port of
		 undefined ->
		     case Encrypt of
		       tls -> ?LDAPS_PORT;
		       _ -> ?LDAP_PORT
		     end;
		 PT -> PT
	       end,
    CertOpts = case proplists:get_value(tls_certfile, Opts) of
		   undefined ->
		       [];
		   Path1 ->
		       [{certfile, Path1}]
	       end,
    CacertOpts = case proplists:get_value(tls_cacertfile, Opts) of
                     undefined ->
                         [];
                     Path2 ->
                         [{cacertfile, Path2}]
                 end,
    DepthOpts = case proplists:get_value(tls_depth, Opts) of
                    undefined ->
                        [];
                    Depth ->
                        [{depth, Depth}]
                end,
    Verify = proplists:get_value(tls_verify, Opts, false),
    TLSOpts = if (Verify == hard orelse Verify == soft)
		   andalso CacertOpts == [] ->
		     ?WARNING_MSG("TLS verification is enabled but no CA "
				  "certfiles configured, so verification "
				  "is disabled.",
				  []),
		     CertOpts;
		 Verify == soft ->
		     [{verify, verify_peer}] ++ CertOpts ++ CacertOpts ++ DepthOpts;
		 Verify == hard ->
		     [{verify, verify_peer}] ++ CertOpts ++ CacertOpts ++ DepthOpts;
		 true -> [{verify, verify_none}]
	      end,
    {ok, connecting,
     #eldap{hosts = Hosts, port = PortTemp, rootdn = Rootdn,
	    passwd = Passwd, tls = Encrypt, tls_options = TLSOpts,
	    id = 0, dict = dict:new(), req_q = queue:new()},
     0}.

connecting(timeout, S) ->
    {ok, NextState, NewS} = connect_bind(S),
    {next_state, NextState, NewS}.

connecting(Event, From, S) ->
    Q = queue:in({Event, From}, S#eldap.req_q),
    {next_state, connecting, S#eldap{req_q = Q}}.

wait_bind_response(Event, From, S) ->
    Q = queue:in({Event, From}, S#eldap.req_q),
    {next_state, wait_bind_response, S#eldap{req_q = Q}}.

active_bind(Event, From, S) ->
    Q = queue:in({Event, From}, S#eldap.req_q),
    {next_state, active_bind, S#eldap{req_q = Q}}.

active(Event, From, S) ->
    process_command(S, Event, From).

%%----------------------------------------------------------------------
%% Func: handle_event/3
%% Called when p1_fsm:send_all_state_event/2 is invoked.
%% Returns: {next_state, NextStateName, NextStateData}          |
%%          {next_state, NextStateName, NextStateData, Timeout} |
%%          {stop, Reason, NewStateData}
%%----------------------------------------------------------------------
handle_event(close, _StateName, S) ->
    catch (S#eldap.sockmod):close(S#eldap.fd),
    {stop, normal, S};
handle_event(_Event, StateName, S) ->
    {next_state, StateName, S}.

handle_sync_event(_Event, _From, StateName, S) ->
    {reply, {StateName, S}, StateName, S}.

%%
%% Packets arriving in various states
%%
handle_info({Tag, _Socket, Data}, connecting, S)
    when Tag == tcp; Tag == ssl ->
    ?DEBUG("TCP packet received when disconnected!~n~p", [Data]),
    {next_state, connecting, S};
handle_info({Tag, _Socket, Data}, wait_bind_response, S)
    when Tag == tcp; Tag == ssl ->
    misc:cancel_timer(S#eldap.bind_timer),
    case catch recvd_wait_bind_response(Data, S) of
      bound -> dequeue_commands(S);
      {fail_bind, Reason} ->
	  report_bind_failure(S#eldap.host, S#eldap.port, Reason),
	  {next_state, connecting,
	   close_and_retry(S, ?GRACEFUL_RETRY_TIMEOUT)};
      {'EXIT', Reason} ->
	  report_bind_failure(S#eldap.host, S#eldap.port, Reason),
	  {next_state, connecting, close_and_retry(S)};
      {error, Reason} ->
	  report_bind_failure(S#eldap.host, S#eldap.port, Reason),
	  {next_state, connecting, close_and_retry(S)}
    end;
handle_info({Tag, _Socket, Data}, StateName, S)
    when (StateName == active orelse StateName == active_bind)
	   andalso (Tag == tcp orelse Tag == ssl) ->
    case catch recvd_packet(Data, S) of
      {response, Response, RequestType} ->
	  NewS = case Response of
		   {reply, Reply, To, S1} -> p1_fsm:reply(To, Reply), S1;
		   {ok, S1} -> S1
		 end,
	  if StateName == active_bind andalso
	       RequestType == bindRequest
	       orelse StateName == active ->
		 dequeue_commands(NewS);
	     true -> {next_state, StateName, NewS}
	  end;
      _ -> {next_state, StateName, S}
    end;
handle_info({Tag, _Socket}, Fsm_state, S)
    when Tag == tcp_closed; Tag == ssl_closed ->
    ?WARNING_MSG("LDAP server closed the connection: ~ts:~p~nIn "
		 "State: ~p",
		 [S#eldap.host, S#eldap.port, Fsm_state]),
    {next_state, connecting, close_and_retry(S)};
handle_info({Tag, _Socket, Reason}, Fsm_state, S)
    when Tag == tcp_error; Tag == ssl_error ->
    ?DEBUG("eldap received tcp_error: ~p~nIn State: ~p",
	   [Reason, Fsm_state]),
    {next_state, connecting, close_and_retry(S)};
%%
%% Timers
%%
handle_info({timeout, Timer, {cmd_timeout, Id}},
	    StateName, S) ->
    case cmd_timeout(Timer, Id, S) of
      {reply, To, Reason, NewS} ->
	  p1_fsm:reply(To, Reason),
	  {next_state, StateName, NewS};
      {error, _Reason} -> {next_state, StateName, S}
    end;
handle_info({timeout, retry_connect}, connecting, S) ->
    {ok, NextState, NewS} = connect_bind(S),
    {next_state, NextState, NewS};
handle_info({timeout, _Timer, bind_timeout}, wait_bind_response, S) ->
    {next_state, connecting, close_and_retry(S)};
%%
%% Make sure we don't fill the message queue with rubbish
%%
handle_info(Info, StateName, S) ->
    ?DEBUG("Unexpected Info: ~p~nIn state: "
	   "~p~n when StateData is: ~p",
	   [Info, StateName, S]),
    {next_state, StateName, S}.

%%----------------------------------------------------------------------
%% Func: terminate/3
%% Purpose: Shutdown the fsm
%% Returns: any
%%----------------------------------------------------------------------
terminate(_Reason, _StateName, _StatData) -> ok.

%%----------------------------------------------------------------------
%% Func: code_change/4
%% Purpose: Convert process state when code is changed
%% Returns: {ok, NewState, NewStateData}
%%----------------------------------------------------------------------
code_change(_OldVsn, StateName, S, _Extra) ->
    {ok, StateName, S}.

%%%----------------------------------------------------------------------
%%% Internal functions
%%%----------------------------------------------------------------------
dequeue_commands(S) ->
    case queue:out(S#eldap.req_q) of
      {{value, {Event, From}}, Q} ->
	  case process_command(S#eldap{req_q = Q}, Event, From) of
	    {_, active, NewS} -> dequeue_commands(NewS);
	    Res -> Res
	  end;
      {empty, _} -> {next_state, active, S}
    end.

process_command(S, Event, From) ->
    case send_command(Event, From, S) of
      {ok, NewS} ->
	  case Event of
	    {bind, _, _} -> {next_state, active_bind, NewS};
	    _ -> {next_state, active, NewS}
	  end;
      {error, _Reason} ->
	  Q = queue:in_r({Event, From}, S#eldap.req_q),
	  NewS = close_and_retry(S#eldap{req_q = Q}),
	  {next_state, connecting, NewS}
    end.

send_command(Command, From, S) ->
    Id = bump_id(S),
    {Name, Request} = gen_req(Command),
    Message = #'LDAPMessage'{messageID = Id,
			     protocolOp = {Name, Request}},
    ?DEBUG("~p~n", [{Name, ejabberd_config:may_hide_data(Request)}]),
    {ok, Bytes} = 'ELDAPv3':encode('LDAPMessage', Message),
    case (S#eldap.sockmod):send(S#eldap.fd, Bytes) of
      ok ->
	Timer = erlang:start_timer(?CMD_TIMEOUT, self(), {cmd_timeout, Id}),
	New_dict = dict:store(Id, [{Timer, Command, From, Name}], S#eldap.dict),
	{ok, S#eldap{id = Id, dict = New_dict}};
      Error ->
	Error
    end.

gen_req({search, A}) ->
    {searchRequest,
     #'SearchRequest'{baseObject = A#eldap_search.base,
		      scope = A#eldap_search.scope,
		      derefAliases = A#eldap_search.deref_aliases,
		      sizeLimit = A#eldap_search.limit,
		      timeLimit = A#eldap_search.timeout,
		      typesOnly = A#eldap_search.types_only,
		      filter = A#eldap_search.filter,
		      attributes = A#eldap_search.attributes}};
gen_req({add, Entry, Attrs}) ->
    {addRequest,
     #'AddRequest'{entry = Entry, attributes = Attrs}};
gen_req({delete, Entry}) -> {delRequest, Entry};
gen_req({modify, Obj, Mod}) ->
    {modifyRequest,
     #'ModifyRequest'{object = Obj, modification = Mod}};
gen_req({modify_dn, Entry, NewRDN, DelOldRDN,
	 NewSup}) ->
    {modDNRequest,
     #'ModifyDNRequest'{entry = Entry, newrdn = NewRDN,
			deleteoldrdn = DelOldRDN, newSuperior = NewSup}};
gen_req({modify_passwd, DN, Passwd}) ->
    {ok, ReqVal} = 'ELDAPv3':encode('PasswdModifyRequestValue',
				    #'PasswdModifyRequestValue'{userIdentity = DN,
								newPasswd =
								    Passwd}),
    {extendedReq,
     #'ExtendedRequest'{requestName = ?passwdModifyOID,
			requestValue = iolist_to_binary(ReqVal)}};
gen_req({bind, RootDN, Passwd}) ->
    {bindRequest,
     #'BindRequest'{version = ?LDAP_VERSION, name = RootDN,
		    authentication = {simple, Passwd}}}.

%%-----------------------------------------------------------------------
%% recvd_packet
%% Deals with incoming packets in the active state
%% Will return one of:
%%  {ok, NewS} - Don't reply to client yet as this is part of a search
%%               result and we haven't got all the answers yet.
%%  {reply, Result, From, NewS} - Reply with result to client From
%%  {error, Reason}
%%  {'EXIT', Reason} - Broke
%%-----------------------------------------------------------------------
recvd_packet(Pkt, S) ->
    case 'ELDAPv3':decode('LDAPMessage', Pkt) of
      {ok, Msg} ->
	  Op = Msg#'LDAPMessage'.protocolOp,
	  ?DEBUG("~p", [Op]),
	  Dict = S#eldap.dict,
	  Id = Msg#'LDAPMessage'.messageID,
	  {Timer, From, Name, Result_so_far} = get_op_rec(Id,
							  Dict),
	  Answer = case {Name, Op} of
		     {searchRequest, {searchResEntry, R}}
			 when is_record(R, 'SearchResultEntry') ->
			 New_dict = dict:append(Id, R, Dict),
			 {ok, S#eldap{dict = New_dict}};
		     {searchRequest, {searchResDone, Result}} ->
			 Reason = Result#'LDAPResult'.resultCode,
			 if Reason == success; Reason == sizeLimitExceeded ->
				{Res, Ref} = polish(Result_so_far),
				New_dict = dict:erase(Id, Dict),
				misc:cancel_timer(Timer),
				{reply,
				 #eldap_search_result{entries = Res,
						      referrals = Ref},
				 From, S#eldap{dict = New_dict}};
			    true ->
				New_dict = dict:erase(Id, Dict),
				misc:cancel_timer(Timer),
				{reply, {error, Reason}, From,
				 S#eldap{dict = New_dict}}
			 end;
		     {searchRequest, {searchResRef, R}} ->
			 New_dict = dict:append(Id, R, Dict),
			 {ok, S#eldap{dict = New_dict}};
		     {addRequest, {addResponse, Result}} ->
			 New_dict = dict:erase(Id, Dict),
			 misc:cancel_timer(Timer),
			 Reply = check_reply(Result, From),
			 {reply, Reply, From, S#eldap{dict = New_dict}};
		     {delRequest, {delResponse, Result}} ->
			 New_dict = dict:erase(Id, Dict),
			 misc:cancel_timer(Timer),
			 Reply = check_reply(Result, From),
			 {reply, Reply, From, S#eldap{dict = New_dict}};
		     {modifyRequest, {modifyResponse, Result}} ->
			 New_dict = dict:erase(Id, Dict),
			 misc:cancel_timer(Timer),
			 Reply = check_reply(Result, From),
			 {reply, Reply, From, S#eldap{dict = New_dict}};
		     {modDNRequest, {modDNResponse, Result}} ->
			 New_dict = dict:erase(Id, Dict),
			 misc:cancel_timer(Timer),
			 Reply = check_reply(Result, From),
			 {reply, Reply, From, S#eldap{dict = New_dict}};
		     {bindRequest, {bindResponse, Result}} ->
			 New_dict = dict:erase(Id, Dict),
			 misc:cancel_timer(Timer),
			 Reply = check_bind_reply(Result, From),
			 {reply, Reply, From, S#eldap{dict = New_dict}};
		     {extendedReq, {extendedResp, Result}} ->
			 New_dict = dict:erase(Id, Dict),
			 misc:cancel_timer(Timer),
			 Reply = check_extended_reply(Result, From),
			 {reply, Reply, From, S#eldap{dict = New_dict}};
		     {OtherName, OtherResult} ->
			 New_dict = dict:erase(Id, Dict),
			 misc:cancel_timer(Timer),
			 {reply,
			  {error, {invalid_result, OtherName, OtherResult}},
			  From, S#eldap{dict = New_dict}}
		   end,
	  {response, Answer, Name};
      Error -> Error
    end.

check_reply(#'LDAPResult'{resultCode = success},
	    _From) ->
    ok;
check_reply(#'LDAPResult'{resultCode = Reason},
	    _From) ->
    {error, Reason};
check_reply(Other, _From) -> {error, Other}.

check_bind_reply(#'BindResponse'{resultCode = success},
		 _From) ->
    ok;
check_bind_reply(#'BindResponse'{resultCode = Reason},
		 _From) ->
    {error, Reason};
check_bind_reply(Other, _From) -> {error, Other}.

%% TODO: process reply depending on requestName:
%% this requires BER-decoding of #'ExtendedResponse'.response
check_extended_reply(#'ExtendedResponse'{resultCode =
					     success},
		     _From) ->
    ok;
check_extended_reply(#'ExtendedResponse'{resultCode =
					     Reason},
		     _From) ->
    {error, Reason};
check_extended_reply(Other, _From) -> {error, Other}.

get_op_rec(Id, Dict) ->
    case dict:find(Id, Dict) of
      {ok, [{Timer, _Command, From, Name} | Res]} ->
	  {Timer, From, Name, Res};
      error -> throw({error, unkown_id})
    end.

%%-----------------------------------------------------------------------
%% recvd_wait_bind_response packet
%% Deals with incoming packets in the wait_bind_response state
%% Will return one of:
%%  bound - Success - move to active state
%%  {fail_bind, Reason} - Failed
%%  {error, Reason}
%%  {'EXIT', Reason} - Broken packet
%%-----------------------------------------------------------------------
recvd_wait_bind_response(Pkt, S) ->
    case 'ELDAPv3':decode('LDAPMessage', Pkt) of
      {ok, Msg} ->
	  ?DEBUG("~p", [Msg]),
	  check_id(S#eldap.id, Msg#'LDAPMessage'.messageID),
	  case Msg#'LDAPMessage'.protocolOp of
	    {bindResponse, Result} ->
		case Result#'BindResponse'.resultCode of
		  success -> bound;
		  Error -> {fail_bind, Error}
		end
	  end;
      Else -> {fail_bind, Else}
    end.

check_id(Id, Id) -> ok;
check_id(_, _) -> throw({error, wrong_bind_id}).

%%-----------------------------------------------------------------------
%% General Helpers
%%-----------------------------------------------------------------------

close_and_retry(S, Timeout) ->
    catch (S#eldap.sockmod):close(S#eldap.fd),
    Queue = dict:fold(fun (_Id,
			   [{Timer, Command, From, _Name} | _], Q) ->
			      misc:cancel_timer(Timer),
			      queue:in_r({Command, From}, Q);
			  (_, _, Q) -> Q
		      end,
		      S#eldap.req_q, S#eldap.dict),
    erlang:send_after(Timeout, self(),
		      {timeout, retry_connect}),
    S#eldap{fd = undefined, req_q = Queue, dict = dict:new()}.

close_and_retry(S) ->
    close_and_retry(S, ?RETRY_TIMEOUT).

report_bind_failure(Host, Port, Reason) ->
    ?WARNING_MSG("LDAP bind failed on ~ts:~p~nReason: ~p",
		 [Host, Port, Reason]).

%%-----------------------------------------------------------------------
%% Sort out timed out commands
%%-----------------------------------------------------------------------
cmd_timeout(Timer, Id, S) ->
    Dict = S#eldap.dict,
    case dict:find(Id, Dict) of
      {ok, [{Timer, _Command, From, Name} | Res]} ->
	  case Name of
	    searchRequest ->
		{Res1, Ref1} = polish(Res),
		New_dict = dict:erase(Id, Dict),
		{reply, From,
		 {timeout,
		  #eldap_search_result{entries = Res1, referrals = Ref1}},
		 S#eldap{dict = New_dict}};
	    _ ->
		New_dict = dict:erase(Id, Dict),
		{reply, From, {error, timeout},
		 S#eldap{dict = New_dict}}
	  end;
      error -> {error, timed_out_cmd_not_in_dict}
    end.

%%-----------------------------------------------------------------------
%% Common stuff for results
%%-----------------------------------------------------------------------
%%%
%%% Polish the returned search result
%%%

polish(Entries) -> polish(Entries, [], []).

polish([H | T], Res, Ref)
    when is_record(H, 'SearchResultEntry') ->
    ObjectName = H#'SearchResultEntry'.objectName,
    F = fun ({_, A, V}) -> {A, V} end,
    Attrs = lists:map(F, H#'SearchResultEntry'.attributes),
    polish(T,
	   [#eldap_entry{object_name = ObjectName,
			 attributes = Attrs}
	    | Res],
	   Ref);
polish([H | T], Res,
       Ref) ->     % No special treatment of referrals at the moment.
    polish(T, Res, [H | Ref]);
polish([], Res, Ref) -> {Res, Ref}.


-ifdef(NO_CUSTOMIZE_HOSTNAME_CHECK).
check_hostname_opt(TLSOpts) ->
    TLSOpts.
-else.
check_hostname_opt(TLSOpts) ->
    MatchFun = public_key:pkix_verify_hostname_match_fun(https),
    [{customize_hostname_check, [{match_fun, MatchFun}]} | TLSOpts].
-endif.

host_tls_options(Host, TLSOpts) ->
    case proplists:get_value(verify, TLSOpts) of
        verify_peer ->
            check_hostname_opt([{server_name_indication, Host} | TLSOpts]);
         _ ->
            TLSOpts
    end.

%%-----------------------------------------------------------------------
%% Connect to next server in list and attempt to bind to it.
%%-----------------------------------------------------------------------
connect_bind(S) ->
    Host = next_host(S#eldap.host, S#eldap.hosts),
    HostS = binary_to_list(Host),
    Opts = if S#eldap.tls == tls ->
		  [{packet, asn1}, {active, true}, {keepalive, true},
		   binary
		   | host_tls_options(HostS, S#eldap.tls_options)];
	      true ->
		  [{packet, asn1}, {active, true}, {keepalive, true},
		   {send_timeout, ?SEND_TIMEOUT}, binary]
	   end,
    ?DEBUG("Connecting to LDAP server at ~ts:~p with options ~p",
	   [Host, S#eldap.port, Opts]),
    SockMod = case S#eldap.tls of
		  tls -> ssl;
		  _ -> gen_tcp
	      end,
    case connect(HostS, S#eldap.port, SockMod, Opts) of
      {ok, Socket} ->
	  case bind_request(Socket, S#eldap{sockmod = SockMod}) of
	    {ok, NewS} ->
		Timer = erlang:start_timer(?BIND_TIMEOUT, self(),
					   {timeout, bind_timeout}),
		{ok, wait_bind_response,
		 NewS#eldap{fd = Socket, sockmod = SockMod, host = Host,
			    bind_timer = Timer}};
	    {error, Reason} ->
		report_bind_failure(Host, S#eldap.port, Reason),
		NewS = close_and_retry(S),
		{ok, connecting, NewS#eldap{host = Host}}
	  end;
      {error, Reason} ->
	  ?ERROR_MSG("LDAP connection to ~ts:~b failed: ~ts",
		     [Host, S#eldap.port, format_error(SockMod, Reason)]),
	  NewS = close_and_retry(S),
	  {ok, connecting, NewS#eldap{host = Host}}
    end.

bind_request(Socket, S) ->
    Id = bump_id(S),
    Req = #'BindRequest'{version = S#eldap.version,
			 name = S#eldap.rootdn,
			 authentication = {simple, S#eldap.passwd}},
    Message = #'LDAPMessage'{messageID = Id,
			     protocolOp = {bindRequest, Req}},
    ?DEBUG("Bind Request Message:~p~n", [ejabberd_config:may_hide_data(Message)]),
    {ok, Bytes} = 'ELDAPv3':encode('LDAPMessage', Message),
    case (S#eldap.sockmod):send(Socket, Bytes) of
      ok -> {ok, S#eldap{id = Id}};
      Error -> Error
    end.

%% Given last tried Server, find next one to try
next_host(undefined, [H | _]) ->
    H;                    % First time, take first
next_host(Host,
	  Hosts) ->                       % Find next in turn
    next_host(Host, Hosts, Hosts).

next_host(Host, [Host], Hosts) ->
    hd(Hosts);    % Wrap back to first
next_host(Host, [Host | Tail], _Hosts) ->
    hd(Tail);       % Take next
next_host(_Host, [], Hosts) ->
    hd(Hosts);       % Never connected before? (shouldn't happen)
next_host(Host, [_ | T], Hosts) ->
    next_host(Host, T, Hosts).

bump_id(#eldap{id = Id})
    when Id > (?MAX_TRANSACTION_ID) ->
    ?MIN_TRANSACTION_ID;
bump_id(#eldap{id = Id}) -> Id + 1.

format_error(SockMod, Reason) ->
    Txt = case SockMod of
	      ssl -> ssl:format_error(Reason);
	      gen_tcp -> inet:format_error(Reason)
	  end,
    case Txt of
	"unknown POSIX error" ->
	    lists:flatten(io_lib:format("~p", [Reason]));
	_ ->
	    Txt
    end.

%%--------------------------------------------------------------------
%% Connecting stuff
%%--------------------------------------------------------------------
-define(CONNECT_TIMEOUT, timer:seconds(15)).
-define(DNS_TIMEOUT, timer:seconds(5)).

connect(Host, Port, Mod, Opts) ->
    case lookup(Host) of
	{ok, AddrsFamilies} ->
	    do_connect(AddrsFamilies, Port, Mod, Opts, {error, nxdomain});
	{error, _} = Err ->
	    Err
    end.

do_connect([{IP, Family}|AddrsFamilies], Port, Mod, Opts, _Err) ->
    case Mod:connect(IP, Port, [Family|Opts], ?CONNECT_TIMEOUT) of
	{ok, Sock} ->
	    {ok, Sock};
	{error, _} = Err ->
	    do_connect(AddrsFamilies, Port, Mod, Opts, Err)
    end;
do_connect([], _Port, _Mod, _Opts, Err) ->
    Err.

lookup(Host) ->
    case inet:parse_address(Host) of
	{ok, IP} ->
	    {ok, [{IP, get_addr_type(IP)}]};
	{error, _} ->
	    do_lookup([{Host, Family} || Family <- [inet6, inet]],
		      [], {error, nxdomain})
    end.

do_lookup([{Host, Family}|HostFamilies], AddrFamilies, Err) ->
    case inet:gethostbyname(Host, Family, ?DNS_TIMEOUT) of
	{ok, HostEntry} ->
	    Addrs = host_entry_to_addrs(HostEntry),
	    AddrFamilies1 = [{Addr, Family} || Addr <- Addrs],
	    do_lookup(HostFamilies,
		      AddrFamilies ++ AddrFamilies1,
		      Err);
	{error, _} = Err1 ->
	    do_lookup(HostFamilies, AddrFamilies, Err1)
    end;
do_lookup([], [], Err) ->
    Err;
do_lookup([], AddrFamilies, _Err) ->
    {ok, AddrFamilies}.

host_entry_to_addrs(#hostent{h_addr_list = AddrList}) ->
    lists:filter(
      fun(Addr) ->
	      try get_addr_type(Addr) of
		  _ -> true
	      catch _:badarg ->
		      false
	      end
      end, AddrList).

get_addr_type({_, _, _, _}) -> inet;
get_addr_type({_, _, _, _, _, _, _, _}) -> inet6;
get_addr_type(_) -> erlang:error(badarg).