InraPorc

unit LDAP;

{

  LDAP Simple Authentification (c)2004 by Paul TOTH <tothpaul@free.fr>

  http://tothpaul.free.fr

}

{

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., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

}

interface

// http://abcdrfc.free.fr/rfc-vf/rfc2251.html

uses

 Dialogs,Winsock,SysUtils;

function LDAPOpen(Server:string; Port:integer=389):integer;

function LDAPBind(LDAP:integer; Name,Password:string):boolean;

function LDAPWhoAmI(LDAP:integer):string;

function LDAPCaps(LDAP:integer):string;

function LDAPSearch(LDAP:integer; Name:string):string;

function LDAPAttribute(LDAP:integer; DN,Attribute:string):string;

procedure LDAPClose(var LDAP:integer);

implementation

const

 LDAP_BOOLEAN     =#$01;

 LDAP_INTEGER     =#$02;

 LDAP_STRING      =#$04;

 LDAP_NULL        =#$05;

 LDAP_ENUM        =#$0A;

 LDAP_SEQUENCE    =#$30;

 LDAP_SET         =#$31;

 LDAP_BIND        =#$60;

 LDAP_BIND_REPLY  =#$61;

 LDAP_SEARCH      =#$63;

 LDAP_SEARCH_ENTRY=#$64;

 LDAP_SEARCH_DONE =#$65;

 LDAP_EXTENDED    =#$77;

 LDAP_FILTER_ANY  =#$87;

 LDAP_FILTER_OR   =#$A1;

 LDAP_FILTER_MATCH=#$A3;

 LDAP_FALSE       = #$00;

 LDAP_TRUE        = #$FF;

 LDAP_WHOAMI      = '1.3.6.1.4.1.4203.1.11.3';

procedure WSAStartup;

var

 WSA:TWSAData;

begin

 Winsock.WSAStartup($101,WSA);

end;

function INetAddr(Host:pansichar):integer;

var

 PHost:PHostEnt;

begin

 Result:=inet_addr(Host);

 if Result=INADDR_NONE then begin

  PHost:=gethostbyname(Host);

  if PHost=nil then exit;

  Result:=integer(pointer(PHost.h_addr^)^);

 end;

end;

function SendData(Socket:integer; var Data; Size:integer):integer;

var

 p:pchar;

 i:integer;

begin

 Result:=Size;

 p:=@Data;

 while Size>0 do begin

  i:=send(Socket,p^,Size,0);

  if i<=0 then begin

   Result:=i;

   exit;

  end;

  dec(Size,i);

  inc(p,i);

 end;

end;

function ReadData(Socket:integer; var Str:string; Min:integer):boolean;

var

 l:integer;

 i:integer;

 b:array[0..1023] of char;

begin

 l:=Length(Str);

 while l<Min do begin

  i:=recv(Socket,b,SizeOf(b),0);

  if i<=0 then begin

   Result:=False;

   exit;

  end;

  SetLength(Str,l+i);

  Move(b,Str[l+1],i);

  inc(l,i);

 end;

 Result:=True;

end;

function BinToInt(var Data; Size:integer):integer;

var

 b:^byte;

begin

 b:=@Data;

 Result:=b^;

 while Size>1 do begin

  Result:=Result shl 8+b^;

  dec(Size);

 end;

end;

function Chunk(Code:char; Data:string):string;

var

 len :integer;

begin

 len:=Length(Data);

 Result:=chr(Len and $FF);

 if len>=128 then begin

  while Len>255 do begin

   Len:=Len shr 8;

   Result:=chr(Len and $FF)+Result;

  end;

  Result:=chr($80+Length(Result))+Result;

 end;

 Result:=Code+Result+Data;

end;

function GetChunk(Code:char; var Data,Chunk:string):boolean;

var

 Head,Size:integer;

begin

 Result:=False;

 if (Data='')or(Data[1]<>Code) then exit;

 Head:=2;

 Size:=ord(Data[Head]);

 if Size>=128 then begin

  Head:=2+Size and $7F;

  Size:=BinToInt(Data[3],Head-2);

 end;

 Chunk:=Copy(Data,Head+1,Size);

 Delete(Data,1,Head+Size);

 Result:=True;

end;

function StrChunk(Var Data:string):string;

begin

 GetChunk(LDAP_STRING,Data,Result);

end;

function IntChunk(var Data:string):integer;

var

 Chunk:string;

begin

 if GetChunk(LDAP_INTEGER,Data,Chunk) then

  Result:=BinToInt(Chunk[1],Length(Chunk))

 else

  Result:=-1;

end;

function EnumChunk(var Data:string):integer;

var

 Chunk:string;

begin

 if GetChunk(LDAP_ENUM,Data,Chunk) then

  Result:=BinToInt(Chunk[1],Length(Chunk))

 else

  Result:=-1;

end;

function OpenChunk(Code:char; var Data:string):boolean;

var

 Chunk:string;

begin

 Result:=False;

 Chunk:=Data;

 if not GetChunk(Code,Chunk,Data) then exit;

 if Chunk<>'' then exit;

 Result:=True;

end;

function ReadSequence(LDAP:integer; var Str,Left:string; Sequence:integer):boolean;

var

 Size:integer;

 Head:integer;

begin

 Result:=False;

// minimum Header

 Head:=2;

 if ReadData(LDAP,Str,Head)=False then exit;

// Sequence

 if Str[1]<>LDAP_SEQUENCE then exit;

// Single byte size

 Size:=ord(Str[2]);

// Multiple byte Size

 if Size>=128 then begin

  Head:=2+Size and $7F;

  if ReadData(LDAP,Str,Head)=False then exit;

  Size:=BinToInt(Str[3],Head-2);

 end;

// Read whole Sequence

 if ReadData(LDAP,Str,Head+Size)=False then exit;

// drop Sequence header

 Delete(Str,1,Head);

 Left:=Copy(Str,Size+1,MaxInt);

 SetLength(Str,Size);

// Skip Sequence number

 if IntChunk(Str)<>Sequence then exit;

// Ok !

 Result:=True;

end;

function LDAPOpen(Server:string; Port:integer=389):integer;

var

 SockAddr:TSockAddr;

begin

 Result:=socket(AF_INET,SOCK_STREAM,IPPROTO_TCP);

 if Result=INVALID_SOCKET then exit;

 FillChar(SockAddr,SizeOf(SockAddr),0);

 SockAddr.sin_family:=AF_INET;

 SockAddr.sin_addr.S_addr:=INetAddr(pansichar(Server));

 SockAddr.sin_port:=htons(Port);

 if connect(Result,SockAddr,SizeOf(SockAddr))<>0 then LDAPClose(Result);

end;

function LDAPBind(LDAP:integer; Name,Password:string):boolean;

var

 s1,s2:string;

begin

 Result:=False;

 s1:=Chunk(LDAP_SEQUENCE,

  Chunk(LDAP_INTEGER,#1)+   // Message ID 1

  Chunk(LDAP_BIND,          // Bind

   Chunk(LDAP_INTEGER,#3)+   // LDAP version 3

   Chunk(LDAP_STRING,Name)+  // UserName

   Chunk(#$80,Password)      // Password

  )

 );

 if SendData(LDAP,s1[1],Length(s1))<=0 then exit;

 s1:='';

 if not ReadSequence(LDAP,s1,s2,1) then exit;

 if s2<>'' then exit;

 if (OpenChunk(LDAP_BIND_REPLY,s1)=False) then exit; // Bind Response

 Result:=EnumChunk(s1)=0;   // OK

 //StrChunk(s1); // DN

 //StrChunk(s1); // ResultString

end;

function LDAPWhoAmI(LDAP:integer):string;

var

 s1,s2:string;

begin

 s1:=Chunk(LDAP_SEQUENCE,

  Chunk(LDAP_INTEGER,#4)+   // Message ID 4

  Chunk(LDAP_EXTENDED,        // Extension

   Chunk(#$80,LDAP_WHOAMI)

  )

 );

 if SendData(LDAP,s1[1],Length(s1))<=0 then exit;

 s1:='';

 if not ReadSequence(LDAP,s1,s2,4) then exit;

 Result:=s1;

end;

function LDAPCaps(LDAP:integer):string;

var

 s1,s2,s3:string;

begin

 s1:=Chunk(LDAP_SEQUENCE, // SEQUENCE

  Chunk(LDAP_INTEGER,#2)+      // Message ID 2

  Chunk(LDAP_SEARCH,     // Search

   Chunk(LDAP_STRING,'')+ // BaseObject

   Chunk(LDAP_ENUM,#0)+ // Scope 2 = Whole Tree

   Chunk(LDAP_ENUM,#3)+ // Aliases 0 = derefaliases

   Chunk(LDAP_INTEGER,#0)+ // Size limite

   Chunk(LDAP_INTEGER,#0)+ // Time limite

   Chunk(LDAP_BOOLEAN,LDAP_FALSE)+ // Type only (boolean)

   Chunk(LDAP_FILTER_ANY,'objectClass')+

   Chunk(LDAP_SEQUENCE,

    Chunk(LDAP_STRING,'supportedCapabilities')

   )

  )

 );

 if SendData(LDAP,s1[1],Length(s1))<=0 then exit;

 s1:='';

 if not ReadSequence(LDAP,s1,s2,2) then exit;

 if not OpenChunk(LDAP_SEARCH_ENTRY,s1) then exit;

  if not ReadSequence(LDAP,s2,s3,2) then exit;

  if s3<>'' then exit;

  if not OpenChunk(LDAP_SEARCH_DONE,s2) then exit; // Search Done

 Result:=s1;

end;

function LDAPSearch(LDAP:integer; Name:string):string;

var

 s1,s2,s3:string;

begin

 Result:='';

 s1:=Chunk(LDAP_SEQUENCE, // SEQUENCE

  Chunk(LDAP_INTEGER,#2)+      // Message ID 2

  Chunk(LDAP_SEARCH,     // Search

   Chunk(LDAP_STRING,'')+ // BaseObject

   Chunk(LDAP_ENUM,#2)+ // Scope 2 = Whole Tree

   Chunk(LDAP_ENUM,#0)+ // Aliases 0 = derefaliases

   Chunk(LDAP_INTEGER,#0)+ // Size limite

   Chunk(LDAP_INTEGER,#0)+ // Time limite

   Chunk(LDAP_BOOLEAN,LDAP_FALSE)+ // Type only (boolean)

   Chunk(LDAP_FILTER_OR, // Filter = OR

    Chunk(LDAP_FILTER_MATCH, // Filter = Equality Match

     Chunk(LDAP_STRING,'cn')+ // common name

     Chunk(LDAP_STRING,Name)

    )+

    Chunk(LDAP_FILTER_MATCH, // Filter = Equality Match

     Chunk(LDAP_STRING,'uid')+ // unique id

     Chunk(LDAP_STRING,Name)

    )

   )+

   Chunk(LDAP_SEQUENCE,

    Chunk(LDAP_NULL,'') // NULL

   )

  )

 );

 if SendData(LDAP,s1[1],Length(s1))<=0 then exit;

 s1:='';

 if not ReadSequence(LDAP,s1,s2,2) then exit;

 if not OpenChunk(LDAP_SEARCH_ENTRY,s1) then exit;

  if not ReadSequence(LDAP,s2,s3,2) then exit;

  if s3<>'' then exit;

  if not OpenChunk(LDAP_SEARCH_DONE,s2) then exit; // Search Done

 Result:=StrChunk(s1);

end;

function LDAPAttribute(LDAP:integer; DN,Attribute:string):string;

var

 s1,s2,s3:string;

begin

 s1:=Chunk(LDAP_SEQUENCE, // SEQUENCE

  Chunk(LDAP_INTEGER,#3)+      // Message ID 2

  Chunk(LDAP_SEARCH,     // Search

   Chunk(LDAP_STRING,DN)+  // BaseObject

   Chunk(LDAP_ENUM,#0)+    // Scope 0 = BaseObject

   Chunk(LDAP_ENUM,#0)+    // Aliases 0 = derefaliases

   Chunk(LDAP_INTEGER,#0)+ // Size limite

   Chunk(LDAP_INTEGER,#0)+ // Time limite

   Chunk(LDAP_BOOLEAN,LDAP_FALSE)+ // Type only (boolean)

   Chunk(LDAP_FILTER_ANY,'objectClass')+ // (objectClass=*)

   Chunk(LDAP_SEQUENCE, // Sub-Sequence

    Chunk(LDAP_STRING,Attribute)

   )

  )

 );

 if SendData(LDAP,s1[1],Length(s1))<=0 then exit;

 s1:='';

 if not ReadSequence(LDAP,s1,s2,3) then exit;

 if not OpenChunk(LDAP_SEARCH_ENTRY,s1) then exit;

  if not ReadSequence(LDAP,s2,s3,3) then exit;

  if s3<>'' then exit;

  if not OpenChunk(LDAP_SEARCH_DONE,s2) then exit; // Search Done

 if StrChunk(s1)<>DN then exit; // DN

 if not OpenChunk(LDAP_SEQUENCE,s1) then exit; // Sequence of Sequence

  if not OpenChunk(LDAP_SEQUENCE,s1) then exit; // Sequence

   if UpperCase(StrChunk(s1))<>UpperCase(Attribute) then exit;

   if not OpenChunk(LDAP_SET,s1) then exit; // Set of

    Result:=StrChunk(s1);

end;

procedure LDAPClose(var LDAP:integer);

begin

 closesocket(LDAP);

 LDAP:=INVALID_SOCKET;

end;

initialization

 WSAStartup;

finalization

 WSACleanup;

end.