ldapclasses.pas

Delphi LDAP Authentication Component delphi ldap控件

  {      LDAPAdmin - LDAPClasses.pas
  *      Copyright (C) 2003-2007 Tihomir Karlovic
  *
  *      Author: Tihomir Karlovic
  *
  *
  * This file 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 file 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA
  }

unit LDAPClasses;

interface

uses Windows, Sysutils, WinLDAP, Classes, Events, Constant;






const
  LdapOpRead            = $FFFFFFFF;
  LdapOpNoop            = $FFFFFFFE;
  LdapOpAdd             = LDAP_MOD_ADD;
  LdapOpReplace         = LDAP_MOD_REPLACE;
  LdapOpDelete          = LDAP_MOD_DELETE;

  SESS_TIMEOUT          = 0;
  SESS_SIZE_LIMIT       = 0;
  SESS_PAGE_SIZE        = 100;
  SESS_REFF_HOP_LIMIT   = 32;

  AUTH_SIMPLE           = $00;
  AUTH_GSS              = $01;
  AUTH_GSS_SASL         = $03;

  StandardOperationalAttributes                          = 'createTimestamp,' +
                                                           'modifyTimestamp,' +
                                                           'creatorsName,' +
                                                           'modifiersName,' +
                                                           'subschemaSubentry,' +
                                                           'structuralObjectClass,' +
                                                           'hasSubordinates,' +
                                                           'entryCSN,' +
                                                           'entryUUID';

type
  ErrLDAP = class(Exception);
  PBytes = array of Byte;
  PCharArray = array of PChar;
  PPLDAPMod = array of PLDAPMod;
  PPLdapBerValA = array of PLdapBerVal;

  TLdapAttributeData = class;
  TLdapAttribute     = class;
  TLdapAttributeList = class;
  TLdapEntry         = class;
  TLdapEntryList     = class;

  TDataType = (dtUnknown, dtText, dtBinary);
  TLdapAttributeStates = set of (asNew, asBrowse, asModified, asDeleted);
  TLdapEntryStates = set of (esNew, esBrowse, esReading, esWriting, esModified, esDeleted);
  TLdapAttributeSortType = (AT_Attribute, AT_DN, AT_RDN, AT_Path);

  TSearchCallback = procedure (Sender: TLdapEntryList; var AbortSearch: Boolean) of object;

  TCompareLdapEntry = procedure(Entry1, Entry2: TLdapEntry; Data: pointer; out Result: Integer) of object;
  TDataNotifyEvent = procedure(Sender: TLdapAttributeData) of object;

  TLdapAuthMethod = Integer;

  TLdapAttributeData = class
  private
    fBerval: record
      Bv_Len: Cardinal;
      Bv_Val: PBytes;
    end;
    fAttribute: TLdapAttribute;
    fEntry: TLdapEntry;
    fModOp: Cardinal;
    fType: TDataType;
    fUtf8: Boolean;
    function GetType: TDataType;
    function GetString: string;
    procedure SetString(AValue: string);
    function BervalAddr: PLdapBerval;
  public
    constructor Create(Attribute: TLdapAttribute); virtual;
    function CompareData(P: Pointer; Length: Integer): Boolean;
    procedure SetData(AData: Pointer; ADataSize: Cardinal);
    procedure Delete;
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToStream(Stream: TStream);
    property DataType: TDataType read GetType;
    property AsString: string read GetString write SetString;
    property DataSize: Cardinal read fBerval.Bv_Len;
    property Data: PBytes read fBerval.Bv_Val;
    property Berval: PLdapBerval read BervalAddr;
    property ModOp: Cardinal read fModOp;
    property Attribute: TLdapAttribute read fAttribute;
  end;

  TLdapAttribute = class
  private
    fState: TLdapAttributeStates;
    fName: string;
    fValues: TList;
    fOwnerList: TLdapAttributeList;
    fEntry: TLdapEntry;
    function GetCount: Integer;
    function GetValue(Index: Integer): TLdapAttributeData;
    function GetString: string;
    procedure SetString(AValue: string);
  public
    constructor Create(const AName: string; OwnerList: TLdapAttributeList); virtual;
    destructor Destroy; override;
    function  AddValue: TLdapAttributeData; overload;
    procedure AddValue(const AValue: string); overload; virtual;
    procedure AddValue(const AData: Pointer; const ADataSize: Cardinal); overload; virtual;
    procedure DeleteValue(const AValue: string); virtual;
    procedure Delete;
    function IndexOf(const AValue: string): Integer; overload;
    function IndexOf(const AData: Pointer; const ADataSize: Cardinal): Integer; overload;
    property State: TLdapAttributeStates read fState;
    property Name: string read fName;
    property Values[Index: Integer]: TLdapAttributeData read GetValue; default;
    property ValueCount: Integer read GetCount;
    property AsString: string read GetString write SetString;
    property Entry: TLdapEntry read fEntry;
  end;

  TLdapAttributeList = class
  private
    fList: TList;
    fEntry: TLdapEntry;
    function GetCount: Integer;
    function GetNode(Index: Integer): TLdapAttribute;
  public
    constructor Create(Entry: TLdapEntry); virtual;
    destructor Destroy; override;
    function Add(const AName: string): TLdapAttribute;
    function IndexOf(const Name: string): Integer;
    function AttributeOf(const Name: string): TLdapAttribute;
    procedure Clear;
    property Items[Index: Integer]: TLdapAttribute read GetNode; default;
    property Count: Integer read GetCount;
  end;

  TLDAPSession = class
  private
    ldappld: PLDAP;
    ldapServer: string;
    ldapUser, ldapPassword: string;
    ldapPort: Integer;
    ldapVersion: Integer;
    ldapBase: string;
    ldapSSL: Boolean;
    ldapAuthMethod: TLdapAuthMethod;
    fTimeLimit: Integer;
    fSizeLimit: Integer;
    fPagedSearch: Boolean;
    fPageSize: Integer;
    fDerefAliases: Integer;
    fChaseReferrals: Boolean;
    fReferralHops: Integer;
    fOnConnect: TNotifyEvent;
    fOnDisconnect: TNotifyEvent;
    fOperationalAttrs: PCharArray;
    procedure LDAPCheck(const err: ULONG; const Critical: Boolean = true);
    procedure SetServer(Server: string);
    procedure SetUser(User: string);
    procedure SetPassword(Password: string);
    procedure SetPort(Port: Integer);
    procedure SetVersion(Version: Integer);
    procedure SetConnect(DoConnect: Boolean);
    procedure SetSSL(SSL: Boolean);
    procedure SetLdapAuthMethod(Method: TLdapAuthMethod);
    procedure SetTimeLimit(const Value: Integer);
    procedure SetSizeLimit(const Value: Integer);
    procedure SetDerefAliases(const Value: Integer);
    procedure SetChaseReferrals(const Value: boolean);
    procedure SetReferralHops(const Value: Integer);
    function  GetOperationalAttrs: string;
    procedure SetOperationalAttrs(const Value: string);
    function  ISConnected: Boolean;
    procedure ProcessSearchEntry(const plmEntry: PLDAPMessage; Attributes: TLdapAttributeList);
    procedure ProcessSearchMessage(const plmSearch: PLDAPMessage; const NoValues: LongBool; Result: TLdapEntryList);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Connect;
    procedure Disconnect;
    property pld: PLDAP read ldappld;
    property Server: string read ldapServer write SetServer;
    property User: string read ldapUser write SetUser;
    property Password: string read ldapPassword write SetPassword;
    property Port: Integer read ldapPort write SetPort;
    property Version: Integer read ldapVersion write SetVersion;
    property SSL: Boolean read ldapSSL write SetSSL;
    property AuthMethod: TLdapAuthMethod read ldapAuthMethod write SetLdapAuthMethod;
    property Base: string read ldapBase write ldapBase;
    property TimeLimit: Integer read fTimeLimit write SetTimeLimit;
    property SizeLimit: Integer read fSizeLimit write SetSizeLimit;
    property PagedSearch: Boolean read fPagedSearch write fPagedSearch;
    property PageSize: Integer read fPageSize write fPageSize;
    property DereferenceAliases: Integer read fDerefAliases write SetDerefAliases;
    property ChaseReferrals: Boolean read fChaseReferrals write SetChaseReferrals;
    property ReferralHops: Integer read fReferralHops write SetReferralHops;
    property Connected: Boolean read IsConnected write SetConnect;
    function Lookup(sBase, sFilter, sResult: string; Scope: ULONG): string;
    function GetDn(sFilter: string): string;
    function GetFreeNumber(const Min, Max: Integer; const Objectclass, id: string): Integer;
    function GetFreeUidNumber(const MinUid, MaxUID: Integer): Integer;
    function GetFreeGidNumber(const MinGid, MaxGID: Integer): Integer;
    procedure Search(const Filter, Base: string; const Scope: Cardinal; QueryAttrs: array of string; const NoValues: LongBool; Result: TLdapEntryList; SearchProc: TSearchCallback = nil); overload;
    procedure Search(const Filter, Base: string; const Scope: Cardinal; attrs: PCharArray; const NoValues: LongBool; Result: TLdapEntryList; SearchProc: TSearchCallback = nil); overload;
    procedure ModifySet(const Filter, Base: string;
                        const Scope: Cardinal;
                        argNames: array of string;
                        argVals: array of string;
                        argNewVals: array of string;
                        const ModOp: Cardinal);
    procedure WriteEntry(Entry: TLdapEntry);
    procedure ReadEntry(Entry: TLdapEntry);
    procedure DeleteEntry(const adn: string);
    property  OnConnect: TNotifyEvent read FOnConnect;
    property  OnDisconnect: TNotifyEvent read FOnDisconnect;
    property  OperationalAttrs: string read GetOperationalAttrs write SetOperationalAttrs;
  end;

  TLDAPEntry = class
  private
    fSession: TLDAPSession;
    fdn: string;
    fAttributes: TLdapAttributeList;
    fOperationalAttributes: TLdapAttributeList;
    fState: TLdapEntryStates;
    fOnChangeProc: TDataNotifyEvent;
    function GetNamedAttribute(const AName: string): TLdapAttribute;
  protected
    procedure SetDn(const adn: string);
  public
    Tag: Integer;
    property Session: TLDAPSession read fSession;
    property dn: string read fdn write SetDn;
    constructor Create(const ASession: TLDAPSession; const adn: string); virtual;
    destructor Destroy; override;
    procedure Read; virtual;
    procedure Write; virtual;
    procedure Delete; virtual;
    property State: TLdapEntryStates read fState;
    property Attributes: TLdapAttributeList read fAttributes;
    property AttributesByName[const Name: string]: TLdapAttribute read GetNamedAttribute;
    property OperationalAttributes: TLdapAttributeList read fOperationalAttributes;
    property OnChange: TDataNotifyEvent read fOnChangeProc write fOnChangeProc;
  end;

  TLdapEntryList = class
  private
    fList:        TList;
    function      GetCount: Integer;
    function      GetNode(Index: Integer): TLdapEntry;
  public
    constructor   Create;
    destructor    Destroy; override;
    procedure     Add(Entry: TLdapEntry);
    procedure     Clear;
    property      Items[Index: Integer]: TLdapEntry read GetNode; default;
    property      Count: Integer read GetCount;
    procedure     Sort(const Attributes: array of string; const Asc: boolean); overload;
    procedure     Sort(const Compare: TCompareLdapEntry; const Asc: boolean; const Data: pointer=nil); overload;
  end;

{ Name handling routines }
function  CanonicalName(dn: string): string;
procedure SplitRdn(const dn: string; var attrib, value: string);
function  GetAttributeFromDn(const dn: string): string;
function  GetNameFromDn(const dn: string): string;
function  GetRdnFromDn(const dn: string): string;
function  GetDirFromDn(const dn: string): string;

function GetAttributeSortType(Attribute: string): TLdapAttributeSortType;

const
  PSEUDOATTR_DN         = '*DN*';
  PSEUDOATTR_RDN        = '*RDN*';
  PSEUDOATTR_PATH       = '*PATH*';


procedure Register;

implementation

uses Misc, Input, Dialogs, Cert, Gss;

{ Name handling routines }
procedure Register;
begin

end;

function CanonicalName(dn: string): string;
var
  comp: PPChar;
  i: Integer;
begin
  Result := '';
  comp := ldap_explode_dn(PChar(dn), 1);
  i := 0;
  if Assigned(comp) then
  while PCharArray(comp)[i] <> nil do
  begin
    Result := Result + PCharArray(comp)[i] + '/';
    inc(i);
  end;
  ldap_value_free(comp);
end;

procedure SplitRdn(const dn: string; var attrib, value: string);
var
  p, p0, p1: PChar;
begin
  p := PChar(dn);
  p0 := p;
  while (p^ <> #0) and (p^ <> '=') do
    p := CharNext(p);
  SetString(attrib, p0, p - p0);
  p := CharNext(p);
  p1 := p;
  while (p1^ <> #0) and (p1^ <> ',') do
    p1 := CharNext(p1);
  SetString(value, P, P1 - P);
end;

function GetAttributeFromDn(const dn: string): string;
var
  p, p1: PChar;
begin
  p := PChar(dn);
  p1 := p;
  while (p1^ <> #0) and (p1^ <> '=') do
    p1 := CharNext(p1);
  SetString(Result, P, P1 - P);
end;

function GetNameFromDn(const dn: string): string;
var
  p, p1: PChar;
begin
  p := PChar(dn);
  while (p^ <> #0) and (p^ <> '=') do
    p := CharNext(p);
  p := CharNext(p);
  p1 := p;
  while (p1^ <> #0) and (p1^ <> ',') do
    p1 := CharNext(p1);
  SetString(Result, P, P1 - P);
end;

function GetRdnFromDn(const dn: string): string;
var
  p, p1: PChar;
begin
  p := PChar(dn);
  p1 := p;
  while (p1^ <> #0) and (p1^ <> ',') do
    p1 := CharNext(p1);
  SetString(Result, P, P1 - P);
end;

function GetDirFromDn(const dn: string): string;
var
  p: PChar;
begin
  p := PChar(dn);
  while (p^ <> #0) do
  begin
    if (p^ = ',') then
    begin
      p := CharNext(p);
      break;
    end;
    p := CharNext(p);
  end;
  Result := p;
end;

function GetAttributeSortType(Attribute: string): TLdapAttributeSortType;
begin
  if Attribute=PSEUDOATTR_DN   then result:=AT_DN   else
  if Attribute=PSEUDOATTR_RDN  then result:=AT_RDN  else
  if Attribute=PSEUDOATTR_PATH then result:=AT_Path else
  result:=AT_Attribute;
end;

{ TLdapSession }

procedure TLdapSession.LDAPCheck(const err: ULONG; const Critical: Boolean = true);
var
  ErrorEx: PChar;
  msg: string;
begin
  if (err = LDAP_SUCCESS) then exit;
  if ((ldap_get_option(pld, LDAP_OPT_SERVER_ERROR, @ErrorEx)=LDAP_SUCCESS) and Assigned(ErrorEx)) then
  begin
    msg := Format(stLdapErrorEx, [ldap_err2string(err), ErrorEx]);
    ldap_memfree(ErrorEx);
  end
  else
    msg := Format(stLdapError, [ldap_err2string(err)]);
  if Critical then
    raise ErrLDAP.Create(msg);
  MessageDlg(msg, mtError, [mbOk], 0);
end;

procedure TLdapSession.ProcessSearchEntry(const plmEntry: PLDAPMessage; Attributes: TLdapAttributeList);
var
  Attr: TLdapAttribute;
  i: Integer;
  pszAttr: PChar;
  pbe: PBerElement;
  ppBer: PPLdapBerVal;
begin
  // loop thru attributes
  pszAttr := ldap_first_attribute(pld, plmEntry, pbe);
  while Assigned(pszAttr) do
  begin