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

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