source: trunk/Packages/synapse/source/lib/ldapsend.pas

Last change on this file was 2, checked in by chronos, 13 years ago
  • Přidáno: Základní kostra projektu.
  • Přidáno: Knihovna synapse.
File size: 36.4 KB
Line 
1{==============================================================================|
2| Project : Ararat Synapse | 001.007.000 |
3|==============================================================================|
4| Content: LDAP client |
5|==============================================================================|
6| Copyright (c)1999-2010, Lukas Gebauer |
7| All rights reserved. |
8| |
9| Redistribution and use in source and binary forms, with or without |
10| modification, are permitted provided that the following conditions are met: |
11| |
12| Redistributions of source code must retain the above copyright notice, this |
13| list of conditions and the following disclaimer. |
14| |
15| Redistributions in binary form must reproduce the above copyright notice, |
16| this list of conditions and the following disclaimer in the documentation |
17| and/or other materials provided with the distribution. |
18| |
19| Neither the name of Lukas Gebauer nor the names of its contributors may |
20| be used to endorse or promote products derived from this software without |
21| specific prior written permission. |
22| |
23| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
24| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
25| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
26| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
27| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
28| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
29| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
30| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
31| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
32| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
33| DAMAGE. |
34|==============================================================================|
35| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
36| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
37| All Rights Reserved. |
38|==============================================================================|
39| Contributor(s): |
40|==============================================================================|
41| History: see HISTORY.HTM from distribution package |
42| (Found at URL: http://www.ararat.cz/synapse/) |
43|==============================================================================}
44
45{:@abstract(LDAP client)
46
47Used RFC: RFC-2251, RFC-2254, RFC-2829, RFC-2830
48}
49
50{$IFDEF FPC}
51 {$MODE DELPHI}
52{$ENDIF}
53{$H+}
54
55{$IFDEF UNICODE}
56 {$WARN IMPLICIT_STRING_CAST OFF}
57 {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
58{$ENDIF}
59
60unit ldapsend;
61
62interface
63
64uses
65 SysUtils, Classes,
66 blcksock, synautil, asn1util, synacode;
67
68const
69 cLDAPProtocol = '389';
70
71 LDAP_ASN1_BIND_REQUEST = $60;
72 LDAP_ASN1_BIND_RESPONSE = $61;
73 LDAP_ASN1_UNBIND_REQUEST = $42;
74 LDAP_ASN1_SEARCH_REQUEST = $63;
75 LDAP_ASN1_SEARCH_ENTRY = $64;
76 LDAP_ASN1_SEARCH_DONE = $65;
77 LDAP_ASN1_SEARCH_REFERENCE = $73;
78 LDAP_ASN1_MODIFY_REQUEST = $66;
79 LDAP_ASN1_MODIFY_RESPONSE = $67;
80 LDAP_ASN1_ADD_REQUEST = $68;
81 LDAP_ASN1_ADD_RESPONSE = $69;
82 LDAP_ASN1_DEL_REQUEST = $4A;
83 LDAP_ASN1_DEL_RESPONSE = $6B;
84 LDAP_ASN1_MODIFYDN_REQUEST = $6C;
85 LDAP_ASN1_MODIFYDN_RESPONSE = $6D;
86 LDAP_ASN1_COMPARE_REQUEST = $6E;
87 LDAP_ASN1_COMPARE_RESPONSE = $6F;
88 LDAP_ASN1_ABANDON_REQUEST = $70;
89 LDAP_ASN1_EXT_REQUEST = $77;
90 LDAP_ASN1_EXT_RESPONSE = $78;
91
92
93type
94
95 {:@abstract(LDAP attribute with list of their values)
96 This class holding name of LDAP attribute and list of their values. This is
97 descendant of TStringList class enhanced by some new properties.}
98 TLDAPAttribute = class(TStringList)
99 private
100 FAttributeName: AnsiString;
101 FIsBinary: Boolean;
102 protected
103 function Get(Index: integer): string; override;
104 procedure Put(Index: integer; const Value: string); override;
105 procedure SetAttributeName(Value: AnsiString);
106 published
107 {:Name of LDAP attribute.}
108 property AttributeName: AnsiString read FAttributeName Write SetAttributeName;
109 {:Return @true when attribute contains binary data.}
110 property IsBinary: Boolean read FIsBinary;
111 end;
112
113 {:@abstract(List of @link(TLDAPAttribute))
114 This object can hold list of TLDAPAttribute objects.}
115 TLDAPAttributeList = class(TObject)
116 private
117 FAttributeList: TList;
118 function GetAttribute(Index: integer): TLDAPAttribute;
119 public
120 constructor Create;
121 destructor Destroy; override;
122 {:Clear list.}
123 procedure Clear;
124 {:Return count of TLDAPAttribute objects in list.}
125 function Count: integer;
126 {:Add new TLDAPAttribute object to list.}
127 function Add: TLDAPAttribute;
128 {:Delete one TLDAPAttribute object from list.}
129 procedure Del(Index: integer);
130 {:Find and return attribute with requested name. Returns nil if not found.}
131 function Find(AttributeName: AnsiString): TLDAPAttribute;
132 {:Find and return attribute value with requested name. Returns empty string if not found.}
133 function Get(AttributeName: AnsiString): string;
134 {:List of TLDAPAttribute objects.}
135 property Items[Index: Integer]: TLDAPAttribute read GetAttribute; default;
136 end;
137
138 {:@abstract(LDAP result object)
139 This object can hold LDAP object. (their name and all their attributes with
140 values)}
141 TLDAPResult = class(TObject)
142 private
143 FObjectName: AnsiString;
144 FAttributes: TLDAPAttributeList;
145 public
146 constructor Create;
147 destructor Destroy; override;
148 published
149 {:Name of this LDAP object.}
150 property ObjectName: AnsiString read FObjectName write FObjectName;
151 {:Here is list of object attributes.}
152 property Attributes: TLDAPAttributeList read FAttributes;
153 end;
154
155 {:@abstract(List of LDAP result objects)
156 This object can hold list of LDAP objects. (for example result of LDAP SEARCH.)}
157 TLDAPResultList = class(TObject)
158 private
159 FResultList: TList;
160 function GetResult(Index: integer): TLDAPResult;
161 public
162 constructor Create;
163 destructor Destroy; override;
164 {:Clear all TLDAPResult objects in list.}
165 procedure Clear;
166 {:Return count of TLDAPResult objects in list.}
167 function Count: integer;
168 {:Create and add new TLDAPResult object to list.}
169 function Add: TLDAPResult;
170 {:List of TLDAPResult objects.}
171 property Items[Index: Integer]: TLDAPResult read GetResult; default;
172 end;
173
174 {:Define possible operations for LDAP MODIFY operations.}
175 TLDAPModifyOp = (
176 MO_Add,
177 MO_Delete,
178 MO_Replace
179 );
180
181 {:Specify possible values for search scope.}
182 TLDAPSearchScope = (
183 SS_BaseObject,
184 SS_SingleLevel,
185 SS_WholeSubtree
186 );
187
188 {:Specify possible values about alias dereferencing.}
189 TLDAPSearchAliases = (
190 SA_NeverDeref,
191 SA_InSearching,
192 SA_FindingBaseObj,
193 SA_Always
194 );
195
196 {:@abstract(Implementation of LDAP client)
197 (version 2 and 3)
198
199 Note: Are you missing properties for setting Username and Password? Look to
200 parent @link(TSynaClient) object!
201
202 Are you missing properties for specify server address and port? Look to
203 parent @link(TSynaClient) too!}
204 TLDAPSend = class(TSynaClient)
205 private
206 FSock: TTCPBlockSocket;
207 FResultCode: Integer;
208 FResultString: AnsiString;
209 FFullResult: AnsiString;
210 FAutoTLS: Boolean;
211 FFullSSL: Boolean;
212 FSeq: integer;
213 FResponseCode: integer;
214 FResponseDN: AnsiString;
215 FReferals: TStringList;
216 FVersion: integer;
217 FSearchScope: TLDAPSearchScope;
218 FSearchAliases: TLDAPSearchAliases;
219 FSearchSizeLimit: integer;
220 FSearchTimeLimit: integer;
221 FSearchResult: TLDAPResultList;
222 FExtName: AnsiString;
223 FExtValue: AnsiString;
224 function Connect: Boolean;
225 function BuildPacket(const Value: AnsiString): AnsiString;
226 function ReceiveResponse: AnsiString;
227 function DecodeResponse(const Value: AnsiString): AnsiString;
228 function LdapSasl(Value: AnsiString): AnsiString;
229 function TranslateFilter(Value: AnsiString): AnsiString;
230 function GetErrorString(Value: integer): AnsiString;
231 public
232 constructor Create;
233 destructor Destroy; override;
234
235 {:Try to connect to LDAP server and start secure channel, when it is required.}
236 function Login: Boolean;
237
238 {:Try to bind to LDAP server with @link(TSynaClient.Username) and
239 @link(TSynaClient.Password). If this is empty strings, then it do annonymous
240 Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous
241 mode.
242
243 This method using plaintext transport of password! It is not secure!}
244 function Bind: Boolean;
245
246 {:Try to bind to LDAP server with @link(TSynaClient.Username) and
247 @link(TSynaClient.Password). If this is empty strings, then it do annonymous
248 Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous
249 mode.
250
251 This method using SASL with DIGEST-MD5 method for secure transfer of your
252 password.}
253 function BindSasl: Boolean;
254
255 {:Close connection to LDAP server.}
256 function Logout: Boolean;
257
258 {:Modify content of LDAP attribute on this object.}
259 function Modify(obj: AnsiString; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean;
260
261 {:Add list of attributes to specified object.}
262 function Add(obj: AnsiString; const Value: TLDAPAttributeList): Boolean;
263
264 {:Delete this LDAP object from server.}
265 function Delete(obj: AnsiString): Boolean;
266
267 {:Modify object name of this LDAP object.}
268 function ModifyDN(obj, newRDN, newSuperior: AnsiString; DeleteoldRDN: Boolean): Boolean;
269
270 {:Try to compare Attribute value with this LDAP object.}
271 function Compare(obj, AttributeValue: AnsiString): Boolean;
272
273 {:Search LDAP base for LDAP objects by Filter.}
274 function Search(obj: AnsiString; TypesOnly: Boolean; Filter: AnsiString;
275 const Attributes: TStrings): Boolean;
276
277 {:Call any LDAPv3 extended command.}
278 function Extended(const Name, Value: AnsiString): Boolean;
279
280 {:Try to start SSL/TLS connection to LDAP server.}
281 function StartTLS: Boolean;
282 published
283 {:Specify version of used LDAP protocol. Default value is 3.}
284 property Version: integer read FVersion Write FVersion;
285
286 {:Result code of last LDAP operation.}
287 property ResultCode: Integer read FResultCode;
288
289 {:Human readable description of result code of last LDAP operation.}
290 property ResultString: AnsiString read FResultString;
291
292 {:Binary string with full last response of LDAP server. This string is
293 encoded by ASN.1 BER encoding! You need this only for debugging.}
294 property FullResult: AnsiString read FFullResult;
295
296 {:If @true, then try to start TSL mode in Login procedure.}
297 property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
298
299 {:If @true, then use connection to LDAP server through SSL/TLS tunnel.}
300 property FullSSL: Boolean read FFullSSL Write FFullSSL;
301
302 {:Sequence number of last LDAp command. It is incremented by any LDAP command.}
303 property Seq: integer read FSeq;
304
305 {:Specify what search scope is used in search command.}
306 property SearchScope: TLDAPSearchScope read FSearchScope Write FSearchScope;
307
308 {:Specify how to handle aliases in search command.}
309 property SearchAliases: TLDAPSearchAliases read FSearchAliases Write FSearchAliases;
310
311 {:Specify result size limit in search command. Value 0 means without limit.}
312 property SearchSizeLimit: integer read FSearchSizeLimit Write FSearchSizeLimit;
313
314 {:Specify search time limit in search command (seconds). Value 0 means
315 without limit.}
316 property SearchTimeLimit: integer read FSearchTimeLimit Write FSearchTimeLimit;
317
318 {:Here is result of search command.}
319 property SearchResult: TLDAPResultList read FSearchResult;
320
321 {:On each LDAP operation can LDAP server return some referals URLs. Here is
322 their list.}
323 property Referals: TStringList read FReferals;
324
325 {:When you call @link(Extended) operation, then here is result Name returned
326 by server.}
327 property ExtName: AnsiString read FExtName;
328
329 {:When you call @link(Extended) operation, then here is result Value returned
330 by server.}
331 property ExtValue: AnsiString read FExtValue;
332
333 {:TCP socket used by all LDAP operations.}
334 property Sock: TTCPBlockSocket read FSock;
335 end;
336
337{:Dump result of LDAP SEARCH into human readable form. Good for debugging.}
338function LDAPResultDump(const Value: TLDAPResultList): AnsiString;
339
340implementation
341
342{==============================================================================}
343function TLDAPAttribute.Get(Index: integer): string;
344begin
345 Result := inherited Get(Index);
346 if FIsbinary then
347 Result := DecodeBase64(Result);
348end;
349
350procedure TLDAPAttribute.Put(Index: integer; const Value: string);
351var
352 s: AnsiString;
353begin
354 s := Value;
355 if FIsbinary then
356 s := EncodeBase64(Value)
357 else
358 s :=UnquoteStr(s, '"');
359 inherited Put(Index, s);
360end;
361
362procedure TLDAPAttribute.SetAttributeName(Value: AnsiString);
363begin
364 FAttributeName := Value;
365 FIsBinary := Pos(';binary', Lowercase(value)) > 0;
366end;
367
368{==============================================================================}
369constructor TLDAPAttributeList.Create;
370begin
371 inherited Create;
372 FAttributeList := TList.Create;
373end;
374
375destructor TLDAPAttributeList.Destroy;
376begin
377 Clear;
378 FAttributeList.Free;
379 inherited Destroy;
380end;
381
382procedure TLDAPAttributeList.Clear;
383var
384 n: integer;
385 x: TLDAPAttribute;
386begin
387 for n := Count - 1 downto 0 do
388 begin
389 x := GetAttribute(n);
390 if Assigned(x) then
391 x.Free;
392 end;
393 FAttributeList.Clear;
394end;
395
396function TLDAPAttributeList.Count: integer;
397begin
398 Result := FAttributeList.Count;
399end;
400
401function TLDAPAttributeList.Get(AttributeName: AnsiString): string;
402var
403 x: TLDAPAttribute;
404begin
405 Result := '';
406 x := self.Find(AttributeName);
407 if x <> nil then
408 if x.Count > 0 then
409 Result := x[0];
410end;
411
412function TLDAPAttributeList.GetAttribute(Index: integer): TLDAPAttribute;
413begin
414 Result := nil;
415 if Index < Count then
416 Result := TLDAPAttribute(FAttributeList[Index]);
417end;
418
419function TLDAPAttributeList.Add: TLDAPAttribute;
420begin
421 Result := TLDAPAttribute.Create;
422 FAttributeList.Add(Result);
423end;
424
425procedure TLDAPAttributeList.Del(Index: integer);
426var
427 x: TLDAPAttribute;
428begin
429 x := GetAttribute(Index);
430 if Assigned(x) then
431 x.free;
432 FAttributeList.Delete(Index);
433end;
434
435function TLDAPAttributeList.Find(AttributeName: AnsiString): TLDAPAttribute;
436var
437 n: integer;
438 x: TLDAPAttribute;
439begin
440 Result := nil;
441 AttributeName := lowercase(AttributeName);
442 for n := 0 to Count - 1 do
443 begin
444 x := GetAttribute(n);
445 if Assigned(x) then
446 if lowercase(x.AttributeName) = Attributename then
447 begin
448 result := x;
449 break;
450 end;
451 end;
452end;
453
454{==============================================================================}
455constructor TLDAPResult.Create;
456begin
457 inherited Create;
458 FAttributes := TLDAPAttributeList.Create;
459end;
460
461destructor TLDAPResult.Destroy;
462begin
463 FAttributes.Free;
464 inherited Destroy;
465end;
466
467{==============================================================================}
468constructor TLDAPResultList.Create;
469begin
470 inherited Create;
471 FResultList := TList.Create;
472end;
473
474destructor TLDAPResultList.Destroy;
475begin
476 Clear;
477 FResultList.Free;
478 inherited Destroy;
479end;
480
481procedure TLDAPResultList.Clear;
482var
483 n: integer;
484 x: TLDAPResult;
485begin
486 for n := Count - 1 downto 0 do
487 begin
488 x := GetResult(n);
489 if Assigned(x) then
490 x.Free;
491 end;
492 FResultList.Clear;
493end;
494
495function TLDAPResultList.Count: integer;
496begin
497 Result := FResultList.Count;
498end;
499
500function TLDAPResultList.GetResult(Index: integer): TLDAPResult;
501begin
502 Result := nil;
503 if Index < Count then
504 Result := TLDAPResult(FResultList[Index]);
505end;
506
507function TLDAPResultList.Add: TLDAPResult;
508begin
509 Result := TLDAPResult.Create;
510 FResultList.Add(Result);
511end;
512
513{==============================================================================}
514constructor TLDAPSend.Create;
515begin
516 inherited Create;
517 FReferals := TStringList.Create;
518 FFullResult := '';
519 FSock := TTCPBlockSocket.Create;
520 FSock.Owner := self;
521 FTimeout := 60000;
522 FTargetPort := cLDAPProtocol;
523 FAutoTLS := False;
524 FFullSSL := False;
525 FSeq := 0;
526 FVersion := 3;
527 FSearchScope := SS_WholeSubtree;
528 FSearchAliases := SA_Always;
529 FSearchSizeLimit := 0;
530 FSearchTimeLimit := 0;
531 FSearchResult := TLDAPResultList.Create;
532end;
533
534destructor TLDAPSend.Destroy;
535begin
536 FSock.Free;
537 FSearchResult.Free;
538 FReferals.Free;
539 inherited Destroy;
540end;
541
542function TLDAPSend.GetErrorString(Value: integer): AnsiString;
543begin
544 case Value of
545 0:
546 Result := 'Success';
547 1:
548 Result := 'Operations error';
549 2:
550 Result := 'Protocol error';
551 3:
552 Result := 'Time limit Exceeded';
553 4:
554 Result := 'Size limit Exceeded';
555 5:
556 Result := 'Compare FALSE';
557 6:
558 Result := 'Compare TRUE';
559 7:
560 Result := 'Auth method not supported';
561 8:
562 Result := 'Strong auth required';
563 9:
564 Result := '-- reserved --';
565 10:
566 Result := 'Referal';
567 11:
568 Result := 'Admin limit exceeded';
569 12:
570 Result := 'Unavailable critical extension';
571 13:
572 Result := 'Confidentality required';
573 14:
574 Result := 'Sasl bind in progress';
575 16:
576 Result := 'No such attribute';
577 17:
578 Result := 'Undefined attribute type';
579 18:
580 Result := 'Inappropriate matching';
581 19:
582 Result := 'Constraint violation';
583 20:
584 Result := 'Attribute or value exists';
585 21:
586 Result := 'Invalid attribute syntax';
587 32:
588 Result := 'No such object';
589 33:
590 Result := 'Alias problem';
591 34:
592 Result := 'Invalid DN syntax';
593 36:
594 Result := 'Alias dereferencing problem';
595 48:
596 Result := 'Inappropriate authentication';
597 49:
598 Result := 'Invalid credentials';
599 50:
600 Result := 'Insufficient access rights';
601 51:
602 Result := 'Busy';
603 52:
604 Result := 'Unavailable';
605 53:
606 Result := 'Unwilling to perform';
607 54:
608 Result := 'Loop detect';
609 64:
610 Result := 'Naming violation';
611 65:
612 Result := 'Object class violation';
613 66:
614 Result := 'Not allowed on non leaf';
615 67:
616 Result := 'Not allowed on RDN';
617 68:
618 Result := 'Entry already exists';
619 69:
620 Result := 'Object class mods prohibited';
621 71:
622 Result := 'Affects multiple DSAs';
623 80:
624 Result := 'Other';
625 else
626 Result := '--unknown--';
627 end;
628end;
629
630function TLDAPSend.Connect: Boolean;
631begin
632 // Do not call this function! It is calling by LOGIN method!
633 FSock.CloseSocket;
634 FSock.LineBuffer := '';
635 FSeq := 0;
636 FSock.Bind(FIPInterface, cAnyPort);
637 if FSock.LastError = 0 then
638 FSock.Connect(FTargetHost, FTargetPort);
639 if FSock.LastError = 0 then
640 if FFullSSL then
641 FSock.SSLDoConnect;
642 Result := FSock.LastError = 0;
643end;
644
645function TLDAPSend.BuildPacket(const Value: AnsiString): AnsiString;
646begin
647 Inc(FSeq);
648 Result := ASNObject(ASNObject(ASNEncInt(FSeq), ASN1_INT) + Value, ASN1_SEQ);
649end;
650
651function TLDAPSend.ReceiveResponse: AnsiString;
652var
653 x: Byte;
654 i,j: integer;
655begin
656 Result := '';
657 FFullResult := '';
658 x := FSock.RecvByte(FTimeout);
659 if x <> ASN1_SEQ then
660 Exit;
661 Result := AnsiChar(x);
662 x := FSock.RecvByte(FTimeout);
663 Result := Result + AnsiChar(x);
664 if x < $80 then
665 i := 0
666 else
667 i := x and $7F;
668 if i > 0 then
669 Result := Result + FSock.RecvBufferStr(i, Ftimeout);
670 if FSock.LastError <> 0 then
671 begin
672 Result := '';
673 Exit;
674 end;
675 //get length of LDAP packet
676 j := 2;
677 i := ASNDecLen(j, Result);
678 //retreive rest of LDAP packet
679 if i > 0 then
680 Result := Result + FSock.RecvBufferStr(i, Ftimeout);
681 if FSock.LastError <> 0 then
682 begin
683 Result := '';
684 Exit;
685 end;
686 FFullResult := Result;
687end;
688
689function TLDAPSend.DecodeResponse(const Value: AnsiString): AnsiString;
690var
691 i, x: integer;
692 Svt: Integer;
693 s, t: AnsiString;
694begin
695 Result := '';
696 FResultCode := -1;
697 FResultstring := '';
698 FResponseCode := -1;
699 FResponseDN := '';
700 FReferals.Clear;
701 i := 1;
702 ASNItem(i, Value, Svt);
703 x := StrToIntDef(ASNItem(i, Value, Svt), 0);
704 if (svt <> ASN1_INT) or (x <> FSeq) then
705 Exit;
706 s := ASNItem(i, Value, Svt);
707 FResponseCode := svt;
708 if FResponseCode in [LDAP_ASN1_BIND_RESPONSE, LDAP_ASN1_SEARCH_DONE,
709 LDAP_ASN1_MODIFY_RESPONSE, LDAP_ASN1_ADD_RESPONSE, LDAP_ASN1_DEL_RESPONSE,
710 LDAP_ASN1_MODIFYDN_RESPONSE, LDAP_ASN1_COMPARE_RESPONSE,
711 LDAP_ASN1_EXT_RESPONSE] then
712 begin
713 FResultCode := StrToIntDef(ASNItem(i, Value, Svt), -1);
714 FResponseDN := ASNItem(i, Value, Svt);
715 FResultString := ASNItem(i, Value, Svt);
716 if FResultString = '' then
717 FResultString := GetErrorString(FResultCode);
718 if FResultCode = 10 then
719 begin
720 s := ASNItem(i, Value, Svt);
721 if svt = $A3 then
722 begin
723 x := 1;
724 while x < Length(s) do
725 begin
726 t := ASNItem(x, s, Svt);
727 FReferals.Add(t);
728 end;
729 end;
730 end;
731 end;
732 Result := Copy(Value, i, Length(Value) - i + 1);
733end;
734
735function TLDAPSend.LdapSasl(Value: AnsiString): AnsiString;
736var
737 nonce, cnonce, nc, realm, qop, uri, response: AnsiString;
738 s: AnsiString;
739 a1, a2: AnsiString;
740 l: TStringList;
741 n: integer;
742begin
743 l := TStringList.Create;
744 try
745 nonce := '';
746 realm := '';
747 l.CommaText := Value;
748 n := IndexByBegin('nonce=', l);
749 if n >= 0 then
750 nonce := UnQuoteStr(Trim(SeparateRight(l[n], 'nonce=')), '"');
751 n := IndexByBegin('realm=', l);
752 if n >= 0 then
753 realm := UnQuoteStr(Trim(SeparateRight(l[n], 'realm=')), '"');
754 cnonce := IntToHex(GetTick, 8);
755 nc := '00000001';
756 qop := 'auth';
757 uri := 'ldap/' + FSock.ResolveIpToName(FSock.GetRemoteSinIP);
758 a1 := md5(FUsername + ':' + realm + ':' + FPassword)
759 + ':' + nonce + ':' + cnonce;
760 a2 := 'AUTHENTICATE:' + uri;
761 s := strtohex(md5(a1))+':' + nonce + ':' + nc + ':' + cnonce + ':'
762 + qop +':'+strtohex(md5(a2));
763 response := strtohex(md5(s));
764
765 Result := 'username="' + Fusername + '",realm="' + realm + '",nonce="';
766 Result := Result + nonce + '",cnonce="' + cnonce + '",nc=' + nc + ',qop=';
767 Result := Result + qop + ',digest-uri="' + uri + '",response=' + response;
768 finally
769 l.Free;
770 end;
771end;
772
773function TLDAPSend.TranslateFilter(Value: AnsiString): AnsiString;
774var
775 x: integer;
776 s, t, l: AnsiString;
777 r: string;
778 c: Ansichar;
779 attr, rule: AnsiString;
780 dn: Boolean;
781begin
782 Result := '';
783 if Value = '' then
784 Exit;
785 s := Value;
786 if Value[1] = '(' then
787 begin
788 x := RPos(')', Value);
789 s := Copy(Value, 2, x - 2);
790 end;
791 if s = '' then
792 Exit;
793 case s[1] of
794 '!':
795 // NOT rule (recursive call)
796 begin
797 Result := ASNOBject(TranslateFilter(GetBetween('(', ')', s)), $A2);
798 end;
799 '&':
800 // AND rule (recursive call)
801 begin
802 repeat
803 t := GetBetween('(', ')', s);
804 s := Trim(SeparateRight(s, t));
805 if s <> '' then
806 if s[1] = ')' then
807 {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1);
808 Result := Result + TranslateFilter(t);
809 until s = '';
810 Result := ASNOBject(Result, $A0);
811 end;
812 '|':
813 // OR rule (recursive call)
814 begin
815 repeat
816 t := GetBetween('(', ')', s);
817 s := Trim(SeparateRight(s, t));
818 if s <> '' then
819 if s[1] = ')' then
820 {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1);
821 Result := Result + TranslateFilter(t);
822 until s = '';
823 Result := ASNOBject(Result, $A1);
824 end;
825 else
826 begin
827 l := Trim(SeparateLeft(s, '='));
828 r := Trim(SeparateRight(s, '='));
829 if l <> '' then
830 begin
831 c := l[Length(l)];
832 case c of
833 ':':
834 // Extensible match
835 begin
836 {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
837 dn := False;
838 attr := '';
839 rule := '';
840 if Pos(':dn', l) > 0 then
841 begin
842 dn := True;
843 l := ReplaceString(l, ':dn', '');
844 end;
845 attr := Trim(SeparateLeft(l, ':'));
846 rule := Trim(SeparateRight(l, ':'));
847 if rule = l then
848 rule := '';
849 if rule <> '' then
850 Result := ASNObject(rule, $81);
851 if attr <> '' then
852 Result := Result + ASNObject(attr, $82);
853 Result := Result + ASNObject(DecodeTriplet(r, '\'), $83);
854 if dn then
855 Result := Result + ASNObject(AsnEncInt($ff), $84)
856 else
857 Result := Result + ASNObject(AsnEncInt(0), $84);
858 Result := ASNOBject(Result, $a9);
859 end;
860 '~':
861 // Approx match
862 begin
863 {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
864 Result := ASNOBject(l, ASN1_OCTSTR)
865 + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
866 Result := ASNOBject(Result, $a8);
867 end;
868 '>':
869 // Greater or equal match
870 begin
871 {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
872 Result := ASNOBject(l, ASN1_OCTSTR)
873 + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
874 Result := ASNOBject(Result, $a5);
875 end;
876 '<':
877 // Less or equal match
878 begin
879 {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
880 Result := ASNOBject(l, ASN1_OCTSTR)
881 + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
882 Result := ASNOBject(Result, $a6);
883 end;
884 else
885 // present
886 if r = '*' then
887 Result := ASNOBject(l, $87)
888 else
889 if Pos('*', r) > 0 then
890 // substrings
891 begin
892 s := Fetch(r, '*');
893 if s <> '' then
894 Result := ASNOBject(DecodeTriplet(s, '\'), $80);
895 while r <> '' do
896 begin
897 if Pos('*', r) <= 0 then
898 break;
899 s := Fetch(r, '*');
900 Result := Result + ASNOBject(DecodeTriplet(s, '\'), $81);
901 end;
902 if r <> '' then
903 Result := Result + ASNOBject(DecodeTriplet(r, '\'), $82);
904 Result := ASNOBject(l, ASN1_OCTSTR)
905 + ASNOBject(Result, ASN1_SEQ);
906 Result := ASNOBject(Result, $a4);
907 end
908 else
909 begin
910 // Equality match
911 Result := ASNOBject(l, ASN1_OCTSTR)
912 + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
913 Result := ASNOBject(Result, $a3);
914 end;
915 end;
916 end;
917 end;
918 end;
919end;
920
921function TLDAPSend.Login: Boolean;
922begin
923 Result := False;
924 if not Connect then
925 Exit;
926 Result := True;
927 if FAutoTLS then
928 Result := StartTLS;
929end;
930
931function TLDAPSend.Bind: Boolean;
932var
933 s: AnsiString;
934begin
935 s := ASNObject(ASNEncInt(FVersion), ASN1_INT)
936 + ASNObject(FUsername, ASN1_OCTSTR)
937 + ASNObject(FPassword, $80);
938 s := ASNObject(s, LDAP_ASN1_BIND_REQUEST);
939 Fsock.SendString(BuildPacket(s));
940 s := ReceiveResponse;
941 DecodeResponse(s);
942 Result := FResultCode = 0;
943end;
944
945function TLDAPSend.BindSasl: Boolean;
946var
947 s, t: AnsiString;
948 x, xt: integer;
949 digreq: AnsiString;
950begin
951 Result := False;
952 if FPassword = '' then
953 Result := Bind
954 else
955 begin
956 digreq := ASNObject(ASNEncInt(FVersion), ASN1_INT)
957 + ASNObject('', ASN1_OCTSTR)
958 + ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR), $A3);
959 digreq := ASNObject(digreq, LDAP_ASN1_BIND_REQUEST);
960 Fsock.SendString(BuildPacket(digreq));
961 s := ReceiveResponse;
962 t := DecodeResponse(s);
963 if FResultCode = 14 then
964 begin
965 s := t;
966 x := 1;
967 t := ASNItem(x, s, xt);
968 s := ASNObject(ASNEncInt(FVersion), ASN1_INT)
969 + ASNObject('', ASN1_OCTSTR)
970 + ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR)
971 + ASNObject(LdapSasl(t), ASN1_OCTSTR), $A3);
972 s := ASNObject(s, LDAP_ASN1_BIND_REQUEST);
973 Fsock.SendString(BuildPacket(s));
974 s := ReceiveResponse;
975 DecodeResponse(s);
976 if FResultCode = 14 then
977 begin
978 Fsock.SendString(BuildPacket(digreq));
979 s := ReceiveResponse;
980 DecodeResponse(s);
981 end;
982 Result := FResultCode = 0;
983 end;
984 end;
985end;
986
987function TLDAPSend.Logout: Boolean;
988begin
989 Fsock.SendString(BuildPacket(ASNObject('', LDAP_ASN1_UNBIND_REQUEST)));
990 FSock.CloseSocket;
991 Result := True;
992end;
993
994function TLDAPSend.Modify(obj: AnsiString; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean;
995var
996 s: AnsiString;
997 n: integer;
998begin
999 s := '';
1000 for n := 0 to Value.Count -1 do
1001 s := s + ASNObject(Value[n], ASN1_OCTSTR);
1002 s := ASNObject(Value.AttributeName, ASN1_OCTSTR) + ASNObject(s, ASN1_SETOF);
1003 s := ASNObject(ASNEncInt(Ord(Op)), ASN1_ENUM) + ASNObject(s, ASN1_SEQ);
1004 s := ASNObject(s, ASN1_SEQ);
1005 s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ);
1006 s := ASNObject(s, LDAP_ASN1_MODIFY_REQUEST);
1007 Fsock.SendString(BuildPacket(s));
1008 s := ReceiveResponse;
1009 DecodeResponse(s);
1010 Result := FResultCode = 0;
1011end;
1012
1013function TLDAPSend.Add(obj: AnsiString; const Value: TLDAPAttributeList): Boolean;
1014var
1015 s, t: AnsiString;
1016 n, m: integer;
1017begin
1018 s := '';
1019 for n := 0 to Value.Count - 1 do
1020 begin
1021 t := '';
1022 for m := 0 to Value[n].Count - 1 do
1023 t := t + ASNObject(Value[n][m], ASN1_OCTSTR);
1024 t := ASNObject(Value[n].AttributeName, ASN1_OCTSTR)
1025 + ASNObject(t, ASN1_SETOF);
1026 s := s + ASNObject(t, ASN1_SEQ);
1027 end;
1028 s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ);
1029 s := ASNObject(s, LDAP_ASN1_ADD_REQUEST);
1030 Fsock.SendString(BuildPacket(s));
1031 s := ReceiveResponse;
1032 DecodeResponse(s);
1033 Result := FResultCode = 0;
1034end;
1035
1036function TLDAPSend.Delete(obj: AnsiString): Boolean;
1037var
1038 s: AnsiString;
1039begin
1040 s := ASNObject(obj, LDAP_ASN1_DEL_REQUEST);
1041 Fsock.SendString(BuildPacket(s));
1042 s := ReceiveResponse;
1043 DecodeResponse(s);
1044 Result := FResultCode = 0;
1045end;
1046
1047function TLDAPSend.ModifyDN(obj, newRDN, newSuperior: AnsiString; DeleteOldRDN: Boolean): Boolean;
1048var
1049 s: AnsiString;
1050begin
1051 s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(newRDN, ASN1_OCTSTR);
1052 if DeleteOldRDN then
1053 s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL)
1054 else
1055 s := s + ASNObject(ASNEncInt(0), ASN1_BOOL);
1056 if newSuperior <> '' then
1057 s := s + ASNObject(newSuperior, $80);
1058 s := ASNObject(s, LDAP_ASN1_MODIFYDN_REQUEST);
1059 Fsock.SendString(BuildPacket(s));
1060 s := ReceiveResponse;
1061 DecodeResponse(s);
1062 Result := FResultCode = 0;
1063end;
1064
1065function TLDAPSend.Compare(obj, AttributeValue: AnsiString): Boolean;
1066var
1067 s: AnsiString;
1068begin
1069 s := ASNObject(Trim(SeparateLeft(AttributeValue, '=')), ASN1_OCTSTR)
1070 + ASNObject(Trim(SeparateRight(AttributeValue, '=')), ASN1_OCTSTR);
1071 s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ);
1072 s := ASNObject(s, LDAP_ASN1_COMPARE_REQUEST);
1073 Fsock.SendString(BuildPacket(s));
1074 s := ReceiveResponse;
1075 DecodeResponse(s);
1076 Result := FResultCode = 0;
1077end;
1078
1079function TLDAPSend.Search(obj: AnsiString; TypesOnly: Boolean; Filter: AnsiString;
1080 const Attributes: TStrings): Boolean;
1081var
1082 s, t, u: AnsiString;
1083 n, i, x: integer;
1084 r: TLDAPResult;
1085 a: TLDAPAttribute;
1086begin
1087 FSearchResult.Clear;
1088 FReferals.Clear;
1089 s := ASNObject(obj, ASN1_OCTSTR);
1090 s := s + ASNObject(ASNEncInt(Ord(FSearchScope)), ASN1_ENUM);
1091 s := s + ASNObject(ASNEncInt(Ord(FSearchAliases)), ASN1_ENUM);
1092 s := s + ASNObject(ASNEncInt(FSearchSizeLimit), ASN1_INT);
1093 s := s + ASNObject(ASNEncInt(FSearchTimeLimit), ASN1_INT);
1094 if TypesOnly then
1095 s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL)
1096 else
1097 s := s + ASNObject(ASNEncInt(0), ASN1_BOOL);
1098 if Filter = '' then
1099 Filter := '(objectclass=*)';
1100 t := TranslateFilter(Filter);
1101 if t = '' then
1102 s := s + ASNObject('', ASN1_NULL)
1103 else
1104 s := s + t;
1105 t := '';
1106 for n := 0 to Attributes.Count - 1 do
1107 t := t + ASNObject(Attributes[n], ASN1_OCTSTR);
1108 s := s + ASNObject(t, ASN1_SEQ);
1109 s := ASNObject(s, LDAP_ASN1_SEARCH_REQUEST);
1110 Fsock.SendString(BuildPacket(s));
1111 repeat
1112 s := ReceiveResponse;
1113 t := DecodeResponse(s);
1114 if FResponseCode = LDAP_ASN1_SEARCH_ENTRY then
1115 begin
1116 //dekoduj zaznam
1117 r := FSearchResult.Add;
1118 n := 1;
1119 r.ObjectName := ASNItem(n, t, x);
1120 ASNItem(n, t, x);
1121 if x = ASN1_SEQ then
1122 begin
1123 while n < Length(t) do
1124 begin
1125 s := ASNItem(n, t, x);
1126 if x = ASN1_SEQ then
1127 begin
1128 i := n + Length(s);
1129 a := r.Attributes.Add;
1130 u := ASNItem(n, t, x);
1131 a.AttributeName := u;
1132 ASNItem(n, t, x);
1133 if x = ASN1_SETOF then
1134 while n < i do
1135 begin
1136 u := ASNItem(n, t, x);
1137 a.Add(u);
1138 end;
1139 end;
1140 end;
1141 end;
1142 end;
1143 if FResponseCode = LDAP_ASN1_SEARCH_REFERENCE then
1144 begin
1145 n := 1;
1146 while n < Length(t) do
1147 FReferals.Add(ASNItem(n, t, x));
1148 end;
1149 until FResponseCode = LDAP_ASN1_SEARCH_DONE;
1150 Result := FResultCode = 0;
1151end;
1152
1153function TLDAPSend.Extended(const Name, Value: AnsiString): Boolean;
1154var
1155 s, t: AnsiString;
1156 x, xt: integer;
1157begin
1158 s := ASNObject(Name, $80);
1159 if Value <> '' then
1160 s := s + ASNObject(Value, $81);
1161 s := ASNObject(s, LDAP_ASN1_EXT_REQUEST);
1162 Fsock.SendString(BuildPacket(s));
1163 s := ReceiveResponse;
1164 t := DecodeResponse(s);
1165 Result := FResultCode = 0;
1166 if Result then
1167 begin
1168 x := 1;
1169 FExtName := ASNItem(x, t, xt);
1170 FExtValue := ASNItem(x, t, xt);
1171 end;
1172end;
1173
1174
1175function TLDAPSend.StartTLS: Boolean;
1176begin
1177 Result := Extended('1.3.6.1.4.1.1466.20037', '');
1178 if Result then
1179 begin
1180 Fsock.SSLDoConnect;
1181 Result := FSock.LastError = 0;
1182 end;
1183end;
1184
1185{==============================================================================}
1186function LDAPResultDump(const Value: TLDAPResultList): AnsiString;
1187var
1188 n, m, o: integer;
1189 r: TLDAPResult;
1190 a: TLDAPAttribute;
1191begin
1192 Result := 'Results: ' + IntToStr(Value.Count) + CRLF +CRLF;
1193 for n := 0 to Value.Count - 1 do
1194 begin
1195 Result := Result + 'Result: ' + IntToStr(n) + CRLF;
1196 r := Value[n];
1197 Result := Result + ' Object: ' + r.ObjectName + CRLF;
1198 for m := 0 to r.Attributes.Count - 1 do
1199 begin
1200 a := r.Attributes[m];
1201 Result := Result + ' Attribute: ' + a.AttributeName + CRLF;
1202 for o := 0 to a.Count - 1 do
1203 Result := Result + ' ' + a[o] + CRLF;
1204 end;
1205 end;
1206end;
1207
1208end.
Note: See TracBrowser for help on using the repository browser.