clsmimemessage.pas

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

{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'GetEmailCertificate before FInternalCertStore');{$ENDIF}
    FInternalCertStore.LoadFromSystemStore(AStoreName);
    Result := GetCertificateByStore(FInternalCertStore, email);
  end;

{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'GetEmailCertificate before return, Result: %d', nil, [Integer(Result)]);{$ENDIF}

{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'GetEmailCertificate'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'GetEmailCertificate', E); raise; end; end;{$ENDIF}
end;

function TclSMimeMessage.GetRecipientCertificate(const AStoreName: string;
  AEmailList: TStrings): TclCertificate;
var
  i: Integer;
begin
  for i := 0 to AEmailList.Count - 1 do
  begin
    Result := GetEmailCertificate(AEmailList[i], AStoreName);
    if (Result <> nil) then Exit;
  end;
  Result := nil;
end;

function TclSMimeMessage.GetCertificate(const AStoreName: string; IsUseSender: Boolean): TclCertificate;
var
  handled: Boolean;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'GetCertificate, storename: %s, usesender %d', nil, [AStoreName, Integer(IsUseSender)]);{$ENDIF}
  Result := nil;
  handled := False;
  DoGetCertificate(Result, handled);
  if (Result = nil) then
  begin
    if IsUseSender then
    begin
      Result := GetEmailCertificate(From, AStoreName);
    end else
    begin
      Result := GetRecipientCertificate(AStoreName, ToList);
      if (Result = nil) then
      begin
        Result := GetRecipientCertificate(AStoreName, CcList);
      end;
      if (Result = nil) then
      begin
        Result := GetRecipientCertificate(AStoreName, BccList);
      end;
    end;
  end;
  if (Result = nil) then
  begin
    raise EclMailMessageError.Create(cCertificateRequired);
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'GetCertificate'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'GetCertificate', E); raise; end; end;{$ENDIF}
end;

function TclSMimeMessage.GetIsEncrypted: Boolean;
begin
  Result := (Pos('pkcs7-mime', LowerCase(ContentType)) > 0)
    and (not SameText(SMimeContentType, 'signed-data'));
end;

function TclSMimeMessage.GetIsMultiPartContent: Boolean;
begin
  Result := inherited GetIsMultiPartContent() and not IsEncrypted;
  if IsParse then
  begin
    Result := Result and not (IsSigned and (LowerCase(ContentType) <> 'multipart/signed'));
  end else
  begin
    Result := Result and not (IsSigned and not IsDetachedSignature);
  end;
end;

function TclSMimeMessage.GetIsSigned: Boolean;
begin
  Result := SameText(ContentType, 'multipart/signed')
    or ((Pos('pkcs7-mime', LowerCase(ContentType)) > 0) and SameText(SMimeContentType, 'signed-data'));
end;

function TclSMimeMessage.CreateSingleBody(ASource: TStrings; ABodies: TclMessageBodies): TclMessageBody;
begin
  if IsEncrypted or (IsSigned and (LowerCase(ContentType) <> 'multipart/signed')) then
  begin
    Result := TclEnvelopedBody.Create(ABodies);
  end else
  begin
    Result := inherited CreateSingleBody(ASource, ABodies);
  end;
end;

procedure TclSMimeMessage.ParseContentType(ASource, AFieldList: TStrings);
var
  s: string;
begin
  inherited ParseContentType(ASource, AFieldList);
  s := GetHeaderFieldValue(ASource, AFieldList, 'Content-Type');
  SMimeContentType := GetHeaderFieldValueItem(s, 'smime-type=');
end;

procedure TclSMimeMessage.SetIsDetachedSignature(const Value: Boolean);
begin
  if (FIsDetachedSignature <> Value) then
  begin
    FIsDetachedSignature := Value;
    Update();
  end;
end;

procedure TclSMimeMessage.SetIsIncludeCertificate(const Value: Boolean);
begin
  if (FIsIncludeCertificate <> Value) then
  begin
    FIsIncludeCertificate := Value;
    Update();
  end;
end;

procedure TclSMimeMessage.SetSMimeContentType(const Value: string);
begin
  if (FSMimeContentType <> Value) then
  begin
    FSMimeContentType := Value;
    Update();
  end;
end;

procedure TclSMimeMessage.SignEnveloped(ACertificate: TclCertificate);
var
  srcData, signedData: TclCryptData;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'SignEnveloped');{$ENDIF}
  srcData := TclCryptData.Create();
  try
    srcData.AssignByStrings(MessageSource);

    signedData := ACertificate.Sign(srcData, IsDetachedSignature, IsIncludeCertificate);
    try
      Bodies.Clear();
      TclEnvelopedBody.Create(Bodies).Data := signedData;
    except
      signedData.Free();
      raise;
    end;

    ContentType := 'application/x-pkcs7-mime';
    SMimeContentType := 'signed-data';
    Encoding := cmMIMEBase64;
  finally
    srcData.Free();
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'SignEnveloped'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'SignEnveloped', E); raise; end; end;{$ENDIF}
end;

procedure TclSMimeMessage.SignDetached(ACertificate: TclCertificate);
var
  i, ind: Integer;
  srcData, signedData: TclCryptData;
  oldIncludeRFC822: Boolean;
  srcStrings, FieldList: TStrings;
  cryptBody: TclSMimeBody;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'SignDetached');{$ENDIF}
  srcData := nil;
  srcStrings := nil;
  FieldList := nil;
  oldIncludeRFC822 := IncludeRFC822Header;
  try
    srcData := TclCryptData.Create();
    srcStrings := TStringList.Create();
    IncludeRFC822Header := False;
    InternalAssignHeader(srcStrings);
    InternalAssignBodies(srcStrings);

    srcStrings.Add('');
    srcData.AssignByStrings(srcStrings);
    srcStrings.Delete(srcStrings.Count - 1);

    signedData := ACertificate.Sign(srcData, IsDetachedSignature, IsIncludeCertificate);
    try
      Bodies.Clear();

      cryptBody := TclSMimeBody.Create(Bodies);

      FieldList := TStringList.Create();
      ind := GetHeaderFieldList(0, srcStrings, FieldList);
      cryptBody.ParseBodyHeader(ind, srcStrings, FieldList);

      ind := ParseAllHeaders(0, srcStrings, cryptBody.Header);
      ParseExtraFields(cryptBody.Header, cryptBody.KnownFields, cryptBody.ExtraFields);
      for i := ind + 1 to srcStrings.Count - 1 do
      begin
        cryptBody.Source.Add(srcStrings[i]);
      end;

      TclEnvelopedBody.Create(Bodies).Data := signedData;
    except
      signedData.Free();
      raise;
    end;
  finally
    IncludeRFC822Header := oldIncludeRFC822;
    FieldList.Free();
    srcStrings.Free();
    srcData.Free();
  end;

  ContentType := 'multipart/signed';
  SMimeContentType := '';
  Encoding := cmNone;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'SignDetached'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'SignDetached', E); raise; end; end;{$ENDIF}
end;

procedure TclSMimeMessage.Sign;
var
  cert: TclCertificate;
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    if (not IsMailMessageDemoDisplayed) and (not IsEncoderDemoDisplayed)
      and (not IsCertDemoDisplayed) then
    begin
      MessageBox(0, 'Please visit www.clevercomponents.com to purchase your ' +
        'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    end;
    IsMailMessageDemoDisplayed := True;
    IsEncoderDemoDisplayed := True;
    IsCertDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}

{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'Sign');{$ENDIF}

  if IsSigned then
  begin
    raise EclMailMessageError.Create(cMessageSigned);
  end;
  FIsSecuring := True;
  BeginUpdate();
  try
    cert := GetCertificate('MY', True);
    if IsDetachedSignature then
    begin
      SignDetached(cert);
    end else
    begin
      SignEnveloped(cert);
    end;
  finally
    EndUpdate();
    FIsSecuring := False;
  end;

{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'Sign'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'Sign', E); raise; end; end;{$ENDIF}
end;

procedure TclSMimeMessage.Verify;
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    if (not IsMailMessageDemoDisplayed) and (not IsEncoderDemoDisplayed)
      and (not IsCertDemoDisplayed) then
    begin
      MessageBox(0, 'Please visit www.clevercomponents.com to purchase your ' +
        'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    end;
    IsMailMessageDemoDisplayed := True;
    IsEncoderDemoDisplayed := True;
    IsCertDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}

  InternalVerify();
end;

function TclSMimeMessage.CreateBody(ABodies: TclMessageBodies;
  const AContentType, ADisposition: string): TclMessageBody;
begin
  if IsSigned then
  begin
    if (LowerCase(ADisposition) = 'attachment')
      and (system.Pos('-signature', LowerCase(AContentType)) > 1) then
    begin
      Result := TclEnvelopedBody.Create(ABodies);
    end else
    begin
      Result := TclSMimeBody.Create(ABodies);
    end;
  end else
  begin
    Result := inherited CreateBody(ABodies, AContentType, ADisposition);
  end;
end;

procedure TclSMimeMessage.VerifyDetached;
var
  cert: TclCertificate;
  msg: TStrings;
  mimeBody: TclSMimeBody;
  srcData: TclCryptData;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'VerifyDetached');{$ENDIF}
  srcData := nil;
  msg := nil;
  try
    srcData := TclCryptData.Create();
    msg := TStringList.Create();
    Assert(Bodies.Count = 2);
    mimeBody := (Bodies[0] as TclSMimeBody);
    msg.AddStrings(mimeBody.Header);
    msg.Add('');
    msg.AddStrings(mimeBody.Source);

    srcData.AssignByStrings(msg);

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

    ContentType := mimeBody.ContentType;
    SetBoundary(mimeBody.Boundary);