File : src/aws-ldap-client.adb
------------------------------------------------------------------------------
-- Ada Web Server --
-- --
-- Copyright (C) 2003 --
-- ACT-Europe --
-- --
-- Authors: Dmitriy Anisimkov - Pascal Obry --
-- --
-- This library 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 library 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 library; if not, write to the Free Software Foundation, --
-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
------------------------------------------------------------------------------
-- $Id: aws-ldap-client.adb,v 1.13 2003/10/06 17:02:27 obry Exp $:
with Ada.Exceptions;
with Ada.Strings.Fixed;
with Interfaces.C.Strings;
with AWS.Utils;
package body AWS.LDAP.Client is
package IC renames Interfaces.C;
use Ada;
use Interfaces.C.Strings;
use type IC.int;
C_Scope : constant array (Scope_Type) of IC.int
:= (LDAP_Scope_Default => Thin.LDAP_SCOPE_DEFAULT,
LDAP_Scope_Base => Thin.LDAP_SCOPE_BASE,
LDAP_Scope_One_Level => Thin.LDAP_SCOPE_ONELEVEL,
LDAP_Scope_Subtree => Thin.LDAP_SCOPE_SUBTREE);
-- Map Scope_Type with the corresponding C values
C_Bool : constant array (Boolean) of IC.int := (False => 0, True => 1);
-- Map Boolean with the corrsponding C values
procedure Raise_Error (Code : in Thin.Return_Code; Message : in String);
pragma No_Return (Raise_Error);
-- Raises LDAP_Error, set exception message to Message, add error message
-- string.
function Attrib (Name, Value : in String) return String;
pragma Inline (Attrib);
-- Returns Name or Name=Value if Value is not the empty string.
procedure Check_Handle (Dir : in Directory);
pragma Inline (Check_Handle);
-- Raises LDAP_Error if Dir is Null_Directory.
------------
-- Attrib --
------------
function Attrib (Name, Value : in String) return String is
begin
if Value = "" then
return Name;
else
return Name & '=' & Value;
end if;
end Attrib;
----------------
-- Attributes --
----------------
function Attributes
(S1, S2, S3, S4, S5, S6, S7, S8, S9, S10 : in String := "")
return String_Set
is
function "+" (S : in String) return Unbounded_String
renames To_Unbounded_String;
begin
if S1 = "" then
return Attribute_Set'(1 .. 0 => Null_Unbounded_String);
elsif S2 = "" then
return (1 => +S1);
elsif S3 = "" then
return (+S1, +S2);
elsif S4 = "" then
return (+S1, +S2, +S3);
elsif S5 = "" then
return (+S1, +S2, +S3, +S4);
elsif S6 = "" then
return (+S1, +S2, +S3, +S4, +S5);
elsif S7 = "" then
return (+S1, +S2, +S3, +S4, +S5, +S6);
elsif S8 = "" then
return (+S1, +S2, +S3, +S4, +S5, +S6, +S7);
elsif S9 = "" then
return (+S1, +S2, +S3, +S4, +S5, +S6, +S7, +S8);
elsif S10 = "" then
return (+S1, +S2, +S3, +S4, +S5, +S6, +S7, +S8, +S9);
else
return (+S1, +S2, +S3, +S4, +S5, +S6, +S7, +S8, +S9, +S10);
end if;
end Attributes;
----------
-- Bind --
----------
procedure Bind
(Dir : in out Directory;
Login : in String;
Password : in String)
is
Res : IC.int;
C_Login : chars_ptr := New_String (Login);
C_Password : chars_ptr := New_String (Password);
begin
Check_Handle (Dir);
Res := Thin.ldap_simple_bind_s (Dir, C_Login, C_Password);
Free (C_Login);
Free (C_Password);
if Res /= Thin.LDAP_SUCCESS then
Dir := Null_Directory;
Raise_Error (Res, "Bind failed");
end if;
end Bind;
-------
-- c --
-------
function c (Val : in String := "") return String is
begin
return Attrib ("c", Val);
end c;
---------
-- Cat --
---------
function Cat
(S1, S2, S3, S4, S5, S6, S7, S8, S9, S10 : in String := "")
return String
is
v : constant Character := ',';
begin
if S1 = "" then
return "";
elsif S2 = "" then
return S1;
elsif S3 = "" then
return S1 & v & S2;
elsif S4 = "" then
return S1 & v & S2 & v & S3;
elsif S5 = "" then
return S1 & v & S2 & v & S3 & v & S4;
elsif S6 = "" then
return S1 & v & S2 & v & S3 & v & S4 & v & S5;
elsif S7 = "" then
return S1 & v & S2 & v & S3 & v & S4 & v & S5 & v & S6;
elsif S8 = "" then
return S1 & v & S2 & v & S3 & v & S4 & v & S5 & v & S6 & v & S7;
elsif S9 = "" then
return S1 & v & S2 & v & S3 & v & S4 & v & S5 & v & S6 & v & S7
& v & S8;
elsif S10 = "" then
return S1 & v & S2 & v & S3 & v & S4 & v & S5 & v & S6 & v & S7
& v & S8 & v & S9;
else
return S1 & v & S2 & v & S3 & v & S4 & v & S5 & v & S6 & v & S7
& v & S8 & v & S9 & v & S10;
end if;
end Cat;
------------------
-- Check_Handle --
------------------
procedure Check_Handle (Dir : in Directory) is
begin
if not Is_Open (Dir) then
Raise_Error
(Thin.LDAP_OPERATIONS_ERROR, "Handle is not initialized.");
end if;
end Check_Handle;
--------
-- cn --
--------
function cn (Val : in String := "") return String is
begin
return Attrib ("cn", Val);
end cn;
-------------------
-- Count_Entries --
-------------------
function Count_Entries
(Dir : in Directory;
Chain : in LDAP_Message)
return Natural is
begin
Check_Handle (Dir);
return Natural (Thin.ldap_count_entries (Dir, Chain));
end Count_Entries;
--------
-- dc --
--------
function dc (Val : in String := "") return String is
begin
return Attrib ("dc", Val);
end dc;
------------
-- DN2UFN --
------------
function DN2UFN (DN : in String) return String is
C_DN : chars_ptr := New_String (DN);
C_UFN : chars_ptr := Thin.ldap_dn2ufn (C_DN);
Result : constant String := Value (C_UFN);
begin
Free (C_DN);
Free (C_UFN);
return Result;
end DN2UFN;
----------------
-- Explode_DN --
----------------
function Explode_DN
(DN : in String;
No_Types : in Boolean := True)
return String_Set
is
C_DN : chars_ptr := New_String (DN);
Res : Thin.Attribute_Set_Access;
N : Natural := 0;
begin
Res := Thin.ldap_explode_dn (C_DN, C_Bool (No_Types));
Free (C_DN);
N := Natural (Thin.ldap_count_values (Res));
declare
Result : String_Set (1 .. N);
begin
for K in Result'Range loop
Result (K)
:= To_Unbounded_String (Value (Thin.Item (Res, IC.int (K))));
end loop;
Thin.ldap_value_free (Res);
return Result;
end;
end Explode_DN;
---------------------
-- First_Attribute --
---------------------
function First_Attribute
(Dir : in Directory;
Node : in LDAP_Message;
BER : access BER_Element)
return String
is
Result : chars_ptr;
begin
Check_Handle (Dir);
Result := Thin.ldap_first_attribute (Dir, Node, BER);
declare
R : constant String := Value (Result);
begin
Free (Result);
return R;
end;
end First_Attribute;
-----------------
-- First_Entry --
-----------------
function First_Entry
(Dir : in Directory;
Chain : in LDAP_Message)
return LDAP_Message is
begin
Check_Handle (Dir);
return Thin.ldap_first_entry (Dir, Chain);
end First_Entry;
-------------------------
-- For_Every_Attribute --
-------------------------
procedure For_Every_Attribute
(Dir : in Directory;
Node : in LDAP_Message)
is
BER : aliased LDAP.Client.BER_Element;
Quit : Boolean;
begin
Check_Handle (Dir);
declare
Attrs : constant String
:= LDAP.Client.First_Attribute (Dir, Node, BER'Unchecked_Access);
begin
Quit := False;
Action (Attrs, Quit);
if not Quit then
loop
declare
Attrs : constant String
:= LDAP.Client.Next_Attribute (Dir, Node, BER);
begin
exit when Attrs = "";
Quit := False;
Action (Attrs, Quit);
exit when Quit;
end;
end loop;
end if;
end;
Free (BER);
end For_Every_Attribute;
---------------------
-- For_Every_Entry --
---------------------
procedure For_Every_Entry (Dir : in Directory; Chain : in LDAP_Message) is
use type LDAP_Message;
Message : LDAP_Message;
Quit : Boolean;
begin
Check_Handle (Dir);
Message := LDAP.Client.First_Entry (Dir, Chain);
while Message /= Null_LDAP_Message loop
Quit := False;
Action (Message, Quit);
exit when Quit;
Message := LDAP.Client.Next_Entry (Dir, Message);
end loop;
end For_Every_Entry;
----------
-- Free --
----------
procedure Free (Chain : in LDAP_Message) is
Res : IC.int;
pragma Warnings (Off, Res);
-- We are not using pragma Unreferenced here because of GNAT 3.15p.
-- It counts left side assignment as a reference.
begin
Res := Thin.ldap_msgfree (Chain);
end Free;
procedure Free (BER : in BER_Element) is
begin
Thin.ber_free (BER, 0);
end Free;
------------
-- Get_DN --
------------
function Get_DN
(Dir : in Directory;
Node : in LDAP_Message)
return String
is
Result : chars_ptr;
begin
Check_Handle (Dir);
Result := Thin.ldap_get_dn (Dir, Node);
return Value (Result);
end Get_DN;
---------------
-- Get_Error --
---------------
function Get_Error
(E : in Ada.Exceptions.Exception_Occurrence)
return Thin.Return_Code
is
Message : constant String := Exceptions.Exception_Message (E);
First, Last : Natural;
begin
First := Strings.Fixed.Index (Message, "[");
if First = 0 then
return Thin.LDAP_SUCCESS;
else
Last := Strings.Fixed.Index (Message, "]");
if Last > First then
declare
Error : constant String := Message (First + 1 .. Last - 1);
begin
if Utils.Is_Number (Error) then
return Thin.Return_Code'Value (Error);
else
return Thin.LDAP_SUCCESS;
end if;
end;
else
return Thin.LDAP_SUCCESS;
end if;
end if;
end Get_Error;
----------------
-- Get_Values --
----------------
function Get_Values
(Dir : in Directory;
Node : in LDAP_Message;
Target : in String)
return String_Set
is
C_Target : chars_ptr := New_String (Target);
Attribs : Thin.Attribute_Set_Access;
N : Natural := 0;
begin
Check_Handle (Dir);
Attribs := Thin.ldap_get_values (Dir, Node, C_Target);
Free (C_Target);
N := Natural (Thin.ldap_count_values (Attribs));
declare
Result : String_Set (1 .. N);
begin
for K in Result'Range loop
Result (K)
:= To_Unbounded_String (Value (Thin.Item (Attribs, IC.int (K))));
end loop;
Thin.ldap_value_free (Attribs);
return Result;
end;
end Get_Values;
---------------
-- givenName --
---------------
function givenName (Val : in String := "") return String is
begin
return Attrib ("givenName", Val);
end givenName;
----------
-- Init --
----------
function Init
(Host : in String;
Port : in Positive := Default_Port)
return Directory
is
use type Thin.LDAP_Type;
C_Host : chars_ptr := New_String (Host);
Dir : Directory;
begin
Dir := Thin.ldap_init (C_Host, IC.int (Port));
Free (C_Host);
return Dir;
end Init;
-------------
-- Is_Open --
-------------
function Is_Open (Dir : in Directory) return Boolean is
use type Thin.LDAP_Type;
begin
return Dir /= Null_Directory;
end Is_Open;
-------
-- l --
-------
function l (Val : in String := "") return String is
begin
return Attrib ("l", Val);
end l;
----------
-- mail --
----------
function mail (Val : in String := "") return String is
begin
return Attrib ("mail", Val);
end mail;
--------------------
-- Next_Attribute --
--------------------
function Next_Attribute
(Dir : in Directory;
Node : in LDAP_Message;
BER : in BER_Element)
return String
is
Result : chars_ptr;
begin
Check_Handle (Dir);
Result := Thin.ldap_next_attribute (Dir, Node, BER);
if Result = Null_Ptr then
return "";
else
declare
R : constant String := Value (Result);
begin
Free (Result);
return R;
end;
end if;
end Next_Attribute;
----------------
-- Next_Entry --
----------------
function Next_Entry
(Dir : in Directory;
Entries : in LDAP_Message)
return LDAP_Message is
begin
Check_Handle (Dir);
return Thin.ldap_next_entry (Dir, Entries);
end Next_Entry;
-------
-- o --
-------
function o (Val : in String := "") return String is
begin
return Attrib ("o", Val);
end o;
--------
-- ou --
--------
function ou (Val : in String := "") return String is
begin
return Attrib ("ou", Val);
end ou;
-----------------
-- Raise_Error --
-----------------
procedure Raise_Error (Code : in Thin.Return_Code; Message : in String) is
Err_Message : constant String := Value (Thin.ldap_err2string (Code));
begin
Exceptions.Raise_Exception
(LDAP_Error'Identity,
Message & " - ["
& AWS.Utils.Image (Integer (Code)) & "] " & Err_Message);
end Raise_Error;
------------
-- Search --
------------
function Search
(Dir : in Directory;
Base : in String;
Filter : in String;
Scope : in Scope_Type := LDAP_Scope_Default;
Attrs : in Attribute_Set := Null_Set;
Attrs_Only : in Boolean := False)
return LDAP_Message
is
Res : IC.int;
C_Base : chars_ptr := New_String (Base);
C_Filter : chars_ptr := New_String (Filter);
Result : aliased LDAP_Message;
begin
Check_Handle (Dir);
if Attrs = Null_Set then
Res := Thin.ldap_search_s
(Dir, C_Base, C_Scope (Scope), C_Filter, Null_Ptr,
C_Bool (Attrs_Only), Result'Unchecked_Access);
if Res /= Thin.LDAP_SUCCESS then
Raise_Error (Res, "Search failed");
end if;
else
declare
Attributes : chars_ptr_array
(IC.size_t (Attrs'First) .. IC.size_t (Attrs'Last + 1));
begin
for K in Attrs'Range loop
Attributes (IC.size_t (K))
:= New_String (To_String (Attrs (K)));
end loop;
Attributes (Attributes'Last) := Null_Ptr;
Res := Thin.ldap_search_s
(Dir, C_Base, C_Scope (Scope), C_Filter, Attributes,
C_Bool (Attrs_Only), Result'Unchecked_Access);
if Res /= Thin.LDAP_SUCCESS then
Raise_Error (Res, "Search failed");
end if;
-- Free Attributes
for K in Attributes'Range loop
Free (Attributes (K));
end loop;
end;
end if;
-- Free all memory
Free (C_Base);
Free (C_Filter);
return Result;
exception
when others =>
Free (C_Base);
Free (C_Filter);
raise;
end Search;
--------
-- sn --
--------
function sn (Val : in String := "") return String is
begin
return Attrib ("sn", Val);
end sn;
--------
-- st --
--------
function st (Val : in String := "") return String is
begin
return Attrib ("st", Val);
end st;
---------------------
-- telephoneNumber --
---------------------
function telephoneNumber (Val : in String := "") return String is
begin
return Attrib ("telephoneNumber", Val);
end telephoneNumber;
---------
-- uid --
---------
function uid (Val : in String := "") return String is
begin
return Attrib ("uid", Val);
end uid;
------------
-- Unbind --
------------
procedure Unbind (Dir : in out Directory) is
Res : IC.int;
pragma Warnings (Off, Res);
-- We are not using pragma Unreferenced here because of GNAT 3.15p.
-- It counts left side assignment as a reference.
begin
if Is_Open (Dir) then
Res := Thin.ldap_unbind_s (Dir);
Dir := Null_Directory;
end if;
end Unbind;
end AWS.LDAP.Client;