ldapsend.pas

snmp设计增加相应SNMP的OID,是实时处理的.

  Result := nil;
  if Index < Count then
    Result := TLDAPAttribute(FAttributeList[Index]);
end;

function TLDAPAttributeList.Add: TLDAPAttribute;
begin
  Result := TLDAPAttribute.Create;
  FAttributeList.Add(Result);
end;

procedure TLDAPAttributeList.Del(Index: integer);
var
  x: TLDAPAttribute;
begin
  x := GetAttribute(Index);
  if Assigned(x) then
    x.free;
  FAttributeList.Delete(Index);
end;

{==============================================================================}
constructor TLDAPResult.Create;
begin
  inherited Create;
  FAttributes := TLDAPAttributeList.Create;
end;

destructor TLDAPResult.Destroy;
begin
  FAttributes.Free;
  inherited Destroy;
end;

{==============================================================================}
constructor TLDAPResultList.Create;
begin
  inherited Create;
  FResultList := TList.Create;
end;

destructor TLDAPResultList.Destroy;
begin
  Clear;
  FResultList.Free;
  inherited Destroy;
end;

procedure TLDAPResultList.Clear;
var
  n: integer;
  x: TLDAPResult;
begin
  for n := Count - 1 downto 0 do
  begin
    x := GetResult(n);
    if Assigned(x) then
      x.Free;
  end;
  FResultList.Clear;
end;

function TLDAPResultList.Count: integer;
begin
  Result := FResultList.Count;
end;

function TLDAPResultList.GetResult(Index: integer): TLDAPResult;
begin
  Result := nil;
  if Index < Count then
    Result := TLDAPResult(FResultList[Index]);
end;

function TLDAPResultList.Add: TLDAPResult;
begin
  Result := TLDAPResult.Create;
  FResultList.Add(Result);
end;

{==============================================================================}
constructor TLDAPSend.Create;
begin
  inherited Create;
  FReferals := TStringList.Create;
  FFullResult := '';
{$IFDEF STREAMSEC}
  FTLSServer := GlobalTLSInternalServer;
  FSock := TSsTCPBlockSocket.Create;
  FSock.BlockingRead := True;
{$ELSE}
  FSock := TTCPBlockSocket.Create;
{$ENDIF}
  FTimeout := 60000;
  FTargetPort := cLDAPProtocol;
  FAutoTLS := False;
  FFullSSL := False;
  FSeq := 0;
  FVersion := 3;
  FSearchScope := SS_WholeSubtree;
  FSearchAliases := SA_Always;
  FSearchSizeLimit := 0;
  FSearchTimeLimit := 0;
  FSearchResult := TLDAPResultList.Create;
end;

destructor TLDAPSend.Destroy;
begin
  FSock.Free;
  FSearchResult.Free;
  FReferals.Free;
  inherited Destroy;
end;

function TLDAPSend.GetErrorString(Value: integer): string;
begin
  case Value of
    0:
      Result := 'Success';
    1:
      Result := 'Operations error';
    2:
      Result := 'Protocol error';
    3:
      Result := 'Time limit Exceeded';
    4:
      Result := 'Size limit Exceeded';
    5:
      Result := 'Compare FALSE';
    6:
      Result := 'Compare TRUE';
    7:
      Result := 'Auth method not supported';
    8:
      Result := 'Strong auth required';
    9:
      Result := '-- reserved --';
    10:
      Result := 'Referal';
    11:
      Result := 'Admin limit exceeded';
    12:
      Result := 'Unavailable critical extension';
    13:
      Result := 'Confidentality required';
    14:
      Result := 'Sasl bind in progress';
    16:
      Result := 'No such attribute';
    17:
      Result := 'Undefined attribute type';
    18:
      Result := 'Inappropriate matching';
    19:
      Result := 'Constraint violation';
    20:
      Result := 'Attribute or value exists';
    21:
      Result := 'Invalid attribute syntax';
    32:
      Result := 'No such object';
    33:
      Result := 'Alias problem';
    34:
      Result := 'Invalid DN syntax';
    36:
      Result := 'Alias dereferencing problem';
    48:
      Result := 'Inappropriate authentication';
    49:
      Result := 'Invalid credentials';
    50:
      Result := 'Insufficient access rights';
    51:
      Result := 'Busy';
    52:
      Result := 'Unavailable';
    53:
      Result := 'Unwilling to perform';
    54:
      Result := 'Loop detect';
    64:
      Result := 'Naming violation';
    65:
      Result := 'Object class violation';
    66:
      Result := 'Not allowed on non leaf';
    67:
      Result := 'Not allowed on RDN';
    68:
      Result := 'Entry already exists';
    69:
      Result := 'Object class mods prohibited';
    71:
      Result := 'Affects multiple DSAs';
    80:
      Result := 'Other';
  else
    Result := '--unknown--';
  end;
end;

function TLDAPSend.Connect: Boolean;
begin
  // Do not call this function! It is calling by LOGIN method!
  FSock.CloseSocket;
  FSock.LineBuffer := '';
  FSeq := 0;
  FSock.Bind(FIPInterface, cAnyPort);
{$IFDEF STREAMSEC}
  if FFullSSL then
  begin
    if Assigned(FTLSServer) then
      FSock.TLSServer := FTLSServer
    else
    begin
      Result := false;
      Exit;
    end;
  end
  else
    FSock.TLSServer := nil;
{$ELSE}
  if FFullSSL then
    FSock.SSLEnabled := True;
{$ENDIF}
  if FSock.LastError = 0 then
    FSock.Connect(FTargetHost, FTargetPort);
  Result := FSock.LastError = 0;
end;

function TLDAPSend.BuildPacket(const Value: string): string;
begin
  Inc(FSeq);
  Result := ASNObject(ASNObject(ASNEncInt(FSeq), ASN1_INT) + Value,  ASN1_SEQ);
end;

function TLDAPSend.ReceiveResponse: string;
var
  x: Byte;
  i,j: integer;
begin
  Result := '';
  FFullResult := '';
  x := FSock.RecvByte(FTimeout);
  if x <> ASN1_SEQ then
    Exit;
  Result := Char(x);
  x := FSock.RecvByte(FTimeout);
  Result := Result + Char(x);
  if x < $80 then
    i := 0
  else
    i := x and $7F;
  if i > 0 then
    Result := Result + FSock.RecvBufferStr(i, Ftimeout);
  if FSock.LastError <> 0 then
  begin
    Result := '';
    Exit;
  end;
  //get length of LDAP packet
  j := 2;
  i := ASNDecLen(j, Result);
  //retreive rest of LDAP packet
  if i > 0 then
    Result := Result + FSock.RecvBufferStr(i, Ftimeout);
  if FSock.LastError <> 0 then
  begin
    Result := '';
    Exit;
  end;
  FFullResult := Result;
end;

function TLDAPSend.DecodeResponse(const Value: string): string;
var
  i, x: integer;
  Svt: Integer;
  s, t: string;
begin
  Result := '';
  FResultCode := -1;
  FResultstring := '';
  FResponseCode := -1;
  FResponseDN := '';
  FReferals.Clear;
  i := 1;
  ASNItem(i, Value, Svt);
  x := StrToIntDef(ASNItem(i, Value, Svt), 0);
  if (svt <> ASN1_INT) or (x <> FSeq) then
    Exit;
  s := ASNItem(i, Value, Svt);
  FResponseCode := svt;
  if FResponseCode in [LDAP_ASN1_BIND_RESPONSE, LDAP_ASN1_SEARCH_DONE,
    LDAP_ASN1_MODIFY_RESPONSE, LDAP_ASN1_ADD_RESPONSE, LDAP_ASN1_DEL_RESPONSE,
    LDAP_ASN1_MODIFYDN_RESPONSE, LDAP_ASN1_COMPARE_RESPONSE,
    LDAP_ASN1_EXT_RESPONSE] then
  begin
    FResultCode := StrToIntDef(ASNItem(i, Value, Svt), -1);
    FResponseDN := ASNItem(i, Value, Svt);
    FResultString := ASNItem(i, Value, Svt);
    if FResultString = '' then
      FResultString := GetErrorString(FResultCode);
    if FResultCode = 10 then
    begin
      s := ASNItem(i, Value, Svt);
      if svt = $A3 then
      begin
        x := 1;
        while x < Length(s) do
        begin
          t := ASNItem(x, s, Svt);
          FReferals.Add(t);
        end;
      end;
    end;
  end;
  Result := Copy(Value, i, Length(Value) - i + 1);
end;

function TLDAPSend.LdapSasl(Value: string): string;
var
  nonce, cnonce, nc, realm, qop, uri, response: string;
  s: string;
  a1, a2: string;
  l: TStringList;
  n: integer;
begin
  l := TStringList.Create;
  try
    nonce := '';
    realm := '';
    l.CommaText := Value;
    n := IndexByBegin('nonce=', l);
    if n >= 0 then
      nonce := UnQuoteStr(Trim(SeparateRight(l[n], 'nonce=')), '"');
    n := IndexByBegin('realm=', l);
    if n >= 0 then
      realm := UnQuoteStr(Trim(SeparateRight(l[n], 'realm=')), '"');
    cnonce := IntToHex(GetTick, 8);
    nc := '00000001';
    qop := 'auth';
    uri := 'ldap/' + FSock.ResolveIpToName(FSock.GetRemoteSinIP);
    a1 := md5(FUsername + ':' + realm + ':' + FPassword)
      + ':' + nonce + ':' + cnonce;
    a2 := 'AUTHENTICATE:' + uri;
    s := strtohex(md5(a1))+':' + nonce + ':' + nc + ':' + cnonce + ':'
      + qop +':'+strtohex(md5(a2));
    response := strtohex(md5(s));

    Result := 'username="' + Fusername + '",realm="' + realm + '",nonce="';
    Result := Result + nonce + '",cnonce="' + cnonce + '",nc=' + nc + ',qop=';
    Result := Result + qop + ',digest-uri="' + uri + '",response=' + response;
  finally
    l.Free;
  end;
end;

function TLDAPSend.TranslateFilter(Value: string): string;
var
  x: integer;
  s, t, l, r: string;
  c: char;
  attr, rule: string;
  dn: Boolean;
begin
  Result := '';
  if Value = '' then
    Exit;
  s := Value;
  if Value[1] = '(' then
  begin
    x := RPos(')', Value);
    s := Copy(Value, 2, x - 2);
  end;
  if s = '' then
    Exit;
  case s[1] of
    '!':
      // NOT rule (recursive call)
      begin
        Result := ASNOBject(TranslateFilter(GetBetween('(', ')', s)), $A2);
      end;
    '&':
      // AND rule (recursive call)
      begin
        repeat
          t := GetBetween('(', ')', s);
          s := Trim(SeparateRight(s, t));
          if s <> '' then
            if s[1] = ')' then
              {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1);
          Result := Result + TranslateFilter(t);
        until s = '';
        Result := ASNOBject(Result, $A0);
      end;
    '|':
      // OR rule (recursive call)
      begin
        repeat
          t := GetBetween('(', ')', s);
          s := Trim(SeparateRight(s, t));