clsmimemessage.pas

来自「Clever_Internet_Suite_6.2的代码 Clever_Int」· PAS 代码 · 共 1,030 行 · 第 1/3 页

    Bodies.Clear();

    ParseBodies(msg);
  finally
    msg.Free();
    srcData.Free();
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'VerifyDetached'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'VerifyDetached', E); raise; end; end;{$ENDIF}
end;

procedure TclSMimeMessage.VerifyEnveloped;
var
  cert: TclCertificate;
  verified: TclCryptData;
  msg: TStrings;
  s: string;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'VerifyEnveloped');{$ENDIF}
  msg := nil;
  verified := nil;
  try
    Assert(Bodies.Count = 1);

    Certificates.AddFromBinary((Bodies[0] as TclEnvelopedBody).Data);
    cert := GetCertificate('addressbook', True);

    verified := cert.VerifyEnveloped((Bodies[0] as TclEnvelopedBody).Data);
    msg := TStringList.Create();
    SetLength(s, verified.DataSize);
    CopyMemory(PChar(s), verified.Data, verified.DataSize);
    msg.Text := s;
    MessageSource := msg;
  finally
    msg.Free();
    verified.Free();
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'VerifyEnveloped'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'VerifyEnveloped', E); raise; end; end;{$ENDIF}
end;

destructor TclSMimeMessage.Destroy;
begin
  inherited Destroy();
  FCertificates.Free();
  FInternalCertStore.Free();
end;

procedure TclSMimeMessage.InternalDecrypt;
var
  cert: TclCertificate;
  decrypted: TclCryptData;
  msg: TStrings;
  s: string;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'InternalDecrypt');{$ENDIF}
  if not IsEncrypted then
  begin
    raise EclMailMessageError.Create(cMessageNotEncrypted);
  end;
  FIsSecuring := True;
  msg := nil;
  decrypted := nil;
  BeginUpdate();
  try
    Assert(Bodies.Count = 1);

    Certificates.AddFromBinary((Bodies[0] as TclEnvelopedBody).Data);
    cert := GetCertificate('MY', False);

    decrypted := cert.Decrypt((Bodies[0] as TclEnvelopedBody).Data);
    msg := TStringList.Create();

    SetLength(s, decrypted.DataSize);
    CopyMemory(PChar(s), decrypted.Data, decrypted.DataSize);

    msg.Text := s;
    MessageSource := msg;
    SMimeContentType := '';
  finally
    msg.Free();
    decrypted.Free();
    EndUpdate();
    FIsSecuring := False;
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'InternalDecrypt'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'InternalDecrypt', E); raise; end; end;{$ENDIF}
end;

procedure TclSMimeMessage.InternalVerify;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'InternalVerify');{$ENDIF}
  if not IsSigned then
  begin
    raise EclMailMessageError.Create(cMessageNotSigned);
  end;
  FIsSecuring := True;
  BeginUpdate();
  try
    if (LowerCase(ContentType) = 'multipart/signed') then
    begin
      VerifyDetached();
    end else
    begin
      VerifyEnveloped();
    end;
  finally
    EndUpdate();
    FIsSecuring := False;
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'InternalVerify'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'InternalVerify', E); raise; end; end;{$ENDIF}
end;

function TclSMimeMessage.GetEncryptCertificates(const AStoreName: string): TclCertificateStore;

  procedure FillRecipientCerts(AStore: TclCertificateStore; const AStoreName: string; AEmailList: TStrings);
  var
    i: Integer;
    cert: TclCertificate;
  begin
    for i := 0 to AEmailList.Count - 1 do
    begin
      cert := GetEmailCertificate(AEmailList[i], AStoreName);
      if (cert = nil) then
      begin
        raise EclCryptError.Create(cCertificateNotFound, -1);
      end;
      AStore.AddFrom(cert);
    end;
  end;

var
  handled: Boolean;
  cert: TclCertificate;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'GetEncryptCertificates: ' + AStoreName);{$ENDIF}
  Result := TclCertificateStore.Create(nil);
  handled := False;
  cert := nil;
  DoGetCertificate(cert, handled);
  if (cert = nil) then
  begin
    FillRecipientCerts(Result, AStoreName, ToList);
    FillRecipientCerts(Result, AStoreName, CcList);
    FillRecipientCerts(Result, AStoreName, BccList);
  end else
  begin
    Result.AddFrom(cert);
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'GetEncryptCertificates, certcount: %d', nil, [Result.Count]);{$ENDIF}
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'GetEncryptCertificates'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'GetEncryptCertificates', E); raise; end; end;{$ENDIF}
end;

{ TclEnvelopedBody }

procedure TclEnvelopedBody.Clear;
begin
  inherited Clear();
  FileName := 'smime.p7s';
  ContentType := 'application/x-pkcs7-signature';
  Encoding := cmMIMEBase64;
end;

procedure TclEnvelopedBody.DataAdded(AData: TStream);
var
  p: Pointer;
begin
  Data.Allocate(AData.Size);
  p := Data.Data;
  AData.Position := 0;
  AData.Read(p^, Data.DataSize);
  inherited DataAdded(AData);
end;

destructor TclEnvelopedBody.Destroy;
begin
  FData.Free();
  inherited Destroy();
end;

procedure TclEnvelopedBody.DoCreate;
begin
  inherited DoCreate();
  FData := TclCryptData.Create();
end;

function TclEnvelopedBody.GetDestinationStream: TStream;
begin
  Result := TMemoryStream.Create();
end;

function TclEnvelopedBody.GetSourceStream: TStream;
begin
  Result := TMemoryStream.Create();
  Result.WriteBuffer(Data.Data^, Data.DataSize);
  Result.Position := 0;
end;

procedure TclEnvelopedBody.SetData(const Value: TclCryptData);
begin
  FData.Free();
  FData := Value;
  GetMailMessage().Update();
end;

{ TclSMimeBody }

procedure TclSMimeBody.Assign(Source: TPersistent);
begin
  if (Source is TclSMimeBody) then
  begin
    Source.Assign((Source as TclSMimeBody).Source);
    Boundary := (Source as TclSMimeBody).Boundary;
  end;
  inherited Assign(Source);
end;

procedure TclSMimeBody.AssignBodyHeader(ASource: TStrings);
begin
  ASource.AddStrings(Header);
  if (Header.Count > 0) then Exit;

  if (ContentType <> '') and (Boundary <> '') then
  begin
    AddHeaderArrayField(ASource, [ContentType, 'boundary="' + Boundary + '"'], 'Content-Type', ';');
  end;
  ASource.AddStrings(ExtraFields);
end;

procedure TclSMimeBody.BeforeDataAdded(AData: TStream);
begin
end;

procedure TclSMimeBody.Clear;
begin
  inherited Clear();
  Source.Clear();
  Boundary := '';
end;

procedure TclSMimeBody.DataAdded(AData: TStream);
var
  s: string;
begin
  SetString(s, nil, AData.Size);
  AData.Position := 0;
  AData.Read(PChar(s)^, AData.Size);
  AddTextStr(FSource, s);
  inherited DataAdded(AData);
end;

procedure TclSMimeBody.DecodeData(ASource, ADestination: TStream);
begin
  ADestination.CopyFrom(ASource, ASource.Size)
end;

destructor TclSMimeBody.Destroy;
begin
  FSource.Free();
  inherited Destroy();
end;

procedure TclSMimeBody.DoCreate;
begin
  inherited DoCreate();
  FSource := TStringList.Create();
  SetListChangedEvent(FSource as TStringList);
end;

procedure TclSMimeBody.EncodeData(ASource, ADestination: TStream);
begin
  ADestination.CopyFrom(ASource, ASource.Size)
end;

function TclSMimeBody.GetDestinationStream: TStream;
begin
  Result := TMemoryStream.Create();
end;

function TclSMimeBody.GetHeader: TStrings;
begin
  Result := RawHeader;
end;

function TclSMimeBody.GetSourceStream: TStream;
var
  s: string;
  size: Integer;
begin
  Result := TMemoryStream.Create();
  s := FSource.Text;
  size := Length(s);
  if (size - Length(#13#10) > 0) then
  begin
    size := size - Length(#13#10);
  end;
  Result.WriteBuffer(Pointer(s)^, size);
  Result.Position := 0;
end;

procedure TclSMimeBody.ParseBodyHeader(ABodyPos: Integer; ASource, AFieldList: TStrings);
var
  s: string;
begin
  inherited ParseBodyHeader(ABodyPos, ASource, AFieldList);
  s := GetHeaderFieldValue(ASource, AFieldList, 'Content-Type');
  Boundary := GetHeaderFieldValueItem(s, 'boundary=');
end;

procedure TclSMimeBody.ReadData(Reader: TReader);
begin
  Source.Text := Reader.ReadString();
  Boundary := Reader.ReadString();
  inherited ReadData(Reader);
end;

procedure TclSMimeBody.SetBoundary(const Value: string);
begin
  if (FBoundary <> Value) then
  begin
    FBoundary := Value;
    GetMailMessage().Update();
  end;
end;

procedure TclSMimeBody.SetHeader(const Value: TStrings);
begin
  RawHeader.Assign(Value);
  GetMailMessage().Update();
end;

procedure TclSMimeBody.SetSource(const Value: TStrings);
begin
  FSource.Assign(Value);
end;

procedure TclSMimeBody.WriteData(Writer: TWriter);
begin
  Writer.WriteString(Source.Text);
  Writer.WriteString(Boundary);
  inherited WriteData(Writer);
end;

end.