{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  11673: IdMessageCoderMIME.pas
{
{   Rev 1.17    5/12/2003 9:18:26 AM  GGrieve
{ use WriteStringToStream
}
{
{   Rev 1.16    5/12/2003 12:31:16 AM  GGrieve
{ Fis WriteBuffer - can't be used in DotNet
}
{
    Rev 1.15    10/17/2003 12:40:20 AM  DSiders
  Added localization comments.
}
{
{   Rev 1.14    05/10/2003 16:41:54  CCostelloe
{ Restructured MIME boundary outputting
}
{
{   Rev 1.13    29/09/2003 13:07:48  CCostelloe
{ Second RandomRange replaced with Random
}
{
{   Rev 1.12    28/09/2003 22:56:30  CCostelloe
{ TIdMessageEncoderInfoMIME.InitializeHeaders now only sets ContentType if it
{ is ''
}
{
{   Rev 1.11    28/09/2003 21:06:52  CCostelloe
{ Recoded RandomRange to Random to suit D% and BCB5
}
{
{   Rev 1.10    26/09/2003 01:05:42  CCostelloe
{ Removed FIndyMultiPartAlternativeBoundary, IFndyMultiPartRelatedBoundary - no
{ longer needed.  Added support for ContentTransferEncoding '8bit'.  Changed
{ nested MIME decoding from finding boundary to finding 'multipart/'.
}
{
{   Rev 1.9    04/09/2003 20:46:38  CCostelloe
{ Added inclusion of =_ in boundary generation in
{ TIdMIMEBoundaryStrings.GenerateStrings
}
{
{   Rev 1.8    30/08/2003 18:39:58  CCostelloe
{ MIME boundaries changed to be random strings
}
{
{   Rev 1.7    07/08/2003 00:56:48  CCostelloe
{ ReadBody altered to allow lines over 16K (arises with long html parts)
}
{
{   Rev 1.6    2003.06.14 11:08:10 PM  czhower
{ AV fix
}
{
{   Rev 1.5    6/14/2003 02:46:42 PM  JPMugaas
{ Kudzu wanted the BeginDecode called after LDecoder was created and EndDecode
{ to be called just before LDecoder was destroyed.
}
{
    Rev 1.4    6/14/2003 1:14:12 PM  BGooijen
  fix for the bug where the attachments are empty
}
{
{   Rev 1.3    6/13/2003 07:58:46 AM  JPMugaas
{ Should now compile with new decoder design.
}
{
{   Rev 1.2    5/23/03 11:24:06 AM  RLebeau
{ Fixed a compiler error for previous changes
}
{
{   Rev 1.1    5/23/03 9:51:18 AM  RLebeau
{ Fixed bug where message body is parsed incorrectly when MIMEBoundary is empty.
}
{
{   Rev 1.0    11/13/2002 07:57:08 AM  JPMugaas
}
unit IdMessageCoderMIME;

{
  2003-Oct-04 Ciaran Costelloe
    Moved boundary out of InitializeHeaders into TIdMessage.GenerateHeader
}

// for all 3 to 4s:
//// TODO: Predict output sizes and presize outputs, then use move on
// presized outputs when possible, or presize only and reposition if stream

interface

uses
  Classes,
  Math,
  IdMessageCoder, IdMessage;

type
  TIdMessageDecoderMIME = class(TIdMessageDecoder)
  protected
    FFirstLine: string;
    FBodyEncoded: Boolean;
    FMIMEBoundary: string;
  public
    constructor Create(AOwner: TComponent); reintroduce; overload;
    constructor Create(AOwner: TComponent; ALine: string); reintroduce; overload;
    function ReadBody(ADestStream: TStream;
      var VMsgEnd: Boolean): TIdMessageDecoder; override;
    procedure ReadHeader; override;
    //
    property MIMEBoundary: string read FMIMEBoundary write FMIMEBoundary;
    property BodyEncoded: Boolean read FBodyEncoded write FBodyEncoded;
  end;

  TIdMessageDecoderInfoMIME = class(TIdMessageDecoderInfo)
  public
    function CheckForStart(ASender: TIdMessage; ALine: string): TIdMessageDecoder; override;
  end;

  TIdMessageEncoderMIME = class(TIdMessageEncoder)
  public
    procedure Encode(ASrc: TStream; ADest: TStream); override;
  end;

  TIdMessageEncoderInfoMIME = class(TIdMessageEncoderInfo)
  public
    constructor Create; override;
    procedure InitializeHeaders(AMsg: TIdMessage); override;
  end;

  TIdMIMEBoundaryStrings = class
  private
    {CC2: After recoding SendBody et al, dont need FIndyMultiPartAlternativeBoundary
    or FIndyMultiPartRelatedBoundary.}
    FIndyMIMEBoundary: string;
    //FIndyMultiPartAlternativeBoundary: string;
    //FIndyMultiPartRelatedBoundary: string;
    procedure GenerateStrings;
  public
    function GenerateRandomChar: Char;
    function IndyMIMEBoundary: string;
    //function IndyMultiPartAlternativeBoundary: string;
    //function IndyMultiPartRelatedBoundary: string;
  end;

var
  //Note the following is created in the initialization section, so that the
  //overhead of boundary creation is only done at most once per session...
  IdMIMEBoundaryStrings: TIdMIMEBoundaryStrings;

const
  //NOTE: If you used IndyMIMEBoundary, just prefix it with "IdMIMEBoundaryStrings." now.
  //IndyMIMEBoundary                 = '=_NextPart_2rfkindysadvnqw3nerasdf'; {do not localize}
  //IndyMultiPartAlternativeBoundary = '=_NextPart_2altrfkindysadvnqw3nerasdf'; {do not localize}
  //IndyMultiPartRelatedBoundary     = '=_NextPart_2relrfksadvnqindyw3nerasdf'; {do not localize}
  MIMEGenericText = 'text/'; {do not localize}
  MIME7Bit = '7bit'; {do not localize}

implementation

uses
  IdCoder, IdCoderMIME, IdCoreGlobal, IdException, IdGlobal, IdResourceStrings, IdCoderQuotedPrintable,
  SysUtils, IdCoderHeader;

{ TIdMIMEBoundaryStrings }
function TIdMIMEBoundaryStrings.GenerateRandomChar: Char;
var
  LOrd: integer;
  LFloat: Double;
begin
  {Allow only digits (ASCII 48-57), uppercase letters (65-90) and lowercase
  letters (97-122), which is 62 possible chars...}
  LFloat := (Random* 61) + 1.5;  //Gives us 1.5 to 62.5
  LOrd := Trunc(LFloat)+47;  //(1..62) -> (48..109)
  if LOrd > 83 then begin
    LOrd := LOrd + 13;  {Move into lowercase letter range}
  end else if LOrd > 57 then begin
    LOrd := LOrd + 7;  {Move into uppercase letter range}
  end;
  Result := Chr(LOrd);
end;

procedure TIdMIMEBoundaryStrings.GenerateStrings;
{This generates random MIME boundaries.  They are only generated once each time
a program containing this unit is run.}
var
  LN: integer;
  LFloat: Double;
begin
  {Generate a string 34 characters long (34 is a whim, not a requirement)...}
  FIndyMIMEBoundary := '1234567890123456789012345678901234';  {do not localize}
  Randomize;
  for LN := 1 to Length(FIndyMIMEBoundary) do begin
    FIndyMIMEBoundary[LN] := GenerateRandomChar;
  end;
  {CC2: RFC 2045 recommends including "=_" in the boundary, insert in random location...}
  //LN := RandomRange(1,Length(FIndyMIMEBoundary)-1);
  LFloat := (Random * (Length(FIndyMIMEBoundary)-2)) + 1.5;  //Gives us 1.5 to Length-0.5
  LN := Trunc(LFloat);  // 1 to Length-1 (we are inserting a 2-char string)
  FIndyMIMEBoundary[LN] := '=';
  FIndyMIMEBoundary[LN+1] := '_';
  {The Alternative boundary is the same with a random lowercase letter added...}
  //FIndyMultiPartAlternativeBoundary := FIndyMIMEBoundary + Chr(RandomRange(97,122));
  {The Related boundary is the same with a random uppercase letter added...}
  //FIndyMultiPartRelatedBoundary     := FIndyMultiPartAlternativeBoundary + Chr(RandomRange(65,90));
end;

function TIdMIMEBoundaryStrings.IndyMIMEBoundary: string;
begin
  if FIndyMIMEBoundary = '' then begin
    GenerateStrings;
  end;
  Result := FIndyMIMEBoundary;
end;
{
function TIdMIMEBoundaryStrings.IndyMultiPartAlternativeBoundary: string;
begin
  if FIndyMIMEBoundary = '' then begin
    GenerateStrings;
  end;
  Result := FIndyMultiPartAlternativeBoundary;
end;
}
{
function TIdMIMEBoundaryStrings.IndyMultiPartRelatedBoundary: string;
begin
  if FIndyMIMEBoundary = '' then begin
    GenerateStrings;
  end;
  Result := FIndyMultiPartRelatedBoundary;
end;
}
{ TIdMessageDecoderInfoMIME }
function TIdMessageDecoderInfoMIME.CheckForStart(ASender: TIdMessage;
 ALine: string): TIdMessageDecoder;
begin
  if Length(ASender.MIMEBoundary.Boundary)>0 then begin
    if AnsiSameText(ALine, '--' + ASender.MIMEBoundary.Boundary) then begin    {Do not Localize}
      Result := TIdMessageDecoderMIME.Create(ASender);
    end else if AnsiSameText(ASender.ContentTransferEncoding, 'base64') or    {Do not Localize}
      AnsiSameText(ASender.ContentTransferEncoding, 'quoted-printable') then begin    {Do not Localize}
        Result := TIdMessageDecoderMIME.Create(ASender, ALine);
    end else begin
      Result := nil;
    end;
  end else begin
    Result := nil;
  end;
end;

{ TIdCoderMIME }

constructor TIdMessageDecoderMIME.Create(AOwner: TComponent);
begin
  inherited;
  if AOwner is TIdMessage then begin
    FMIMEBoundary := TIdMessage(AOwner).MIMEBoundary.Boundary;
    {CC2: Check to see if this is an email of the type that is headers followed
    by the body encoded in base64 or quoted-printable.  The problem with this type
    is that the header may state it as MIME, but the MIME parts and their headers
    will be encoded, so we won't find them - in this case, we will later take
    all the info we need from the message header, and not try to take it from
    the part header.}
    if (TIdMessage(AOwner).ContentTransferEncoding <> '') and
      {CC2: added 8bit below, changed to AnsiSameText.  Reason is that many emails
      set the Content-Transfer-Encoding to 8bit, have multiple parts, and display
      the part header in plain-text.}
      (AnsiSameText(TIdMessage(AOwner).ContentTransferEncoding, '8bit') = False) and  {do not localize}
      (AnsiSameText(TIdMessage(AOwner).ContentTransferEncoding, '7bit') = False) and  {do not localize}
      (AnsiSameText(TIdMessage(AOwner).ContentTransferEncoding, 'binary') = False)    {do not localize}
      then begin
      FBodyEncoded := True;
    end else begin
      FBodyEncoded := False;
    end;
  end;
end;

constructor TIdMessageDecoderMIME.Create(AOwner: TComponent; ALine: string);
begin
  Create(AOwner);
  FFirstLine := ALine;
end;

function TIdMessageDecoderMIME.ReadBody(ADestStream: TStream; var VMsgEnd: Boolean): TIdMessageDecoder;
var
  s: string;
  LDecoder: TIdDecoder;
  LLine: string;
  LWasSplit: Boolean;
begin
  VMsgEnd := FALSE;
  Result := nil;
  if FBodyEncoded then begin
    s := TIdMessage(Owner).ContentTransferEncoding;
  end else begin
    s := FHeaders.Values['Content-Transfer-Encoding']; {Do not Localize}
  end;
  if AnsiSameText(s, 'base64') then begin {Do not Localize}
    LDecoder := TIdDecoderMIME.Create(nil);
  end else if AnsiSameText(s, 'quoted-printable') then begin {Do not Localize}
    LDecoder := TIdDecoderQuotedPrintable.Create(nil);
  end else begin
    LDecoder := nil;
  end;
  try
    if LDecoder <> nil then begin
      LDecoder.DecodeBegin(ADestStream);
    end;
    repeat
      if FFirstLine = '' then begin                                          
        //LLine := ReadLn;
        {CC: Allow lines over 16K (happens with long html parts)}
        LLine := '';
        repeat
          LLine := LLine + ReadLnSplit(LWasSplit);
        until LWasSplit = False;
      end else begin
        LLine := FFirstLine;
        FFirstLine := '';    {Do not Localize}
      end;
      if LLine = '.' then begin // Do not use ADELIM since always ends with . (standard) {Do not Localize}
        VMsgEnd := True;
        Break;
      end;
      // New boundary - end self and create new coder
      if Length(MIMEBoundary) > 0 then begin
        if AnsiSameText(LLine, '--' + MIMEBoundary) then begin    {Do not Localize}
          Result := TIdMessageDecoderMIME.Create(Owner);
          Break;
        // End of all coders (not quite ALL coders)
        end
        else if AnsiSameText(LLine, '--' + MIMEBoundary + '--') then begin    {Do not Localize}
          // POP the boundary
          if Owner is TIdMessage then begin
            TIdMessage(Owner).MIMEBoundary.Pop;
          end;
          Break;
        // Data to save, but not decode
        end else if LDecoder = nil then begin
          if (Length(LLine) > 0) and (LLine[1] = '.') then begin // Process . in front for no encoding    {Do not Localize}
            Delete(LLine, 1, 1);
          end;
          LLine := LLine + EOL;
          ADestStream.WriteBuffer(LLine[1], Length(LLine));
        // Data to decode
        end else begin
          // For TIdDecoderQuotedPrintable, we have to make sure all EOLs are
          // intact
          if LDecoder is TIdDecoderQuotedPrintable then begin
            LDecoder.Decode(LLine + EOL);
          end else if LLine <> '' then begin
            LDecoder.Decode(LLine);
          end;
        end;
      end else begin  {CC3: Added "else" for QP and base64 encoded message BODIES}
        // For TIdDecoderQuotedPrintable, we have to make sure all EOLs are
        // intact
        if LDecoder is TIdDecoderQuotedPrintable then begin
          LDecoder.Decode(LLine + EOL);
        end else if LLine <> '' then begin
          LDecoder.Decode(LLine);
        end;
      end;
    until False;
    if LDecoder <> nil then begin
      LDecoder.DecodeEnd;
    end;
  finally FreeAndNil(LDecoder); end;
end;

procedure TIdMessageDecoderMIME.ReadHeader;
var
  ABoundary,
  s: string;
  LLine: string;

  procedure CheckAndSetType(AContentType, AContentDisposition: string);
  var
    S: string;
    LFileNamePos: Integer; //APR BugFix #515207
  begin
    s := AContentDisposition;
    s := Fetch(s, ';');    {Do not Localize}
    // Content-Disposition: inline; - Even this we treat as attachment. It can easily
    // contain binary data which text part is not suited for.
    if (AnsiSameText(s, 'attachment')) or (IndyPos('NAME', UpperCase(AContentType)) > 0) then begin  {Do not Localize}
      FPartType := mcptAttachment;
      s := AContentDisposition;

      LFileNamePos := IndyPos('FILENAME', UpperCase(s));  {do not localize}
      if LFileNamePos > 0 then begin
        s := Copy(s, LFileNamePos + 9, Length(s));    {do not localize}
      end else begin
        S := ''; //FileName not found
      end;
      if Length(s) = 0 then begin
        // Get filename from Content-Type
        s := AContentType;
        s := Copy(s, IndyPos('NAME', UpperCase(s)) + 5, Length(s));    {do not localize}
      end;
      if Length(s) > 0 then begin
        if s[1] = '"' then begin    {do not localize}
          Fetch(s, '"');    {do not localize}
          FFilename := Fetch(s, '"');    {do not localize}
        end else begin
          FFilename := s;
        end;
        FFilename := DecodeHeader(FFileName);
      end;
    end else begin
      FPartType := mcptText;
    end;
  end;

begin
  if FBodyEncoded then begin // Read header from the actual message since body parts don't exist    {Do not Localize}
    CheckAndSetType(TIdMessage(Owner).ContentType, TIdMessage(OWner).ContentDisposition);
  end else begin
    // Read header
    repeat
      LLine := ReadLn;
      if LLine = '.' then begin                                                            
        FPartType := mcptUnknown;
        Exit;
      end;//if
      if LLine = '' then begin
        Break;
      end;
      if LLine[1] in LWS then begin
        if FHeaders.Count > 0 then begin
          FHeaders[FHeaders.Count - 1] := FHeaders[FHeaders.Count - 1] + ' ' + Copy(LLine, 2, MaxInt);    {Do not Localize}
        end else begin
          FHeaders.Add(StringReplace(Copy(LLine, 2, MaxInt), ': ', '=', [])); {Do not Localize}
        end;
      end else begin
        FHeaders.Add(StringReplace(LLine, ': ', '=', []));    {Do not Localize}
      end;
    until False;
    s := FHeaders.Values['Content-Type'];    {do not localize}
    //CC: Need to detect on "multipart" rather than boundary, because only the
    //"multipart" bit will be visible later...
    if AnsiSameText(Copy(s, 1, 10), 'multipart/') then begin  {do not localize}
      ABoundary := TIdMIMEBoundary.FindBoundary(s);
      if Owner is TIdMessage then begin
        if Length(ABoundary) > 0 then begin
          TIdMessage(Owner).MIMEBoundary.Push(ABoundary, TIdMessage(Owner).MessageParts.Count);
          // Also update current boundary
          FMIMEBoundary := ABoundary;
        end else begin
          //CC: We are in trouble.  A multipart MIME Content-Type with no boundary?
          //Try pushing the current boundary...
          TIdMessage(Owner).MIMEBoundary.Push(FMIMEBoundary, TIdMessage(Owner).MessageParts.Count);
        end;
      end;
    end;
    CheckAndSetType(FHeaders.Values['Content-Type']    {do not localize}
     , FHeaders.Values['Content-Disposition']);    {do not localize}
  end;
end;

{ TIdMessageEncoderInfoMIME }

constructor TIdMessageEncoderInfoMIME.Create;
begin
  inherited;
  FMessageEncoderClass := TIdMessageEncoderMIME;
end;

procedure TIdMessageEncoderInfoMIME.InitializeHeaders(AMsg: TIdMessage);
begin
  {CC2: The following logic does not work - it assumes that just because there
  are related parts, that the message header is multipart/related, whereas it
  could be multipart/related inside multipart/alternative, plus there are other
  issues.
  But...it works on simple emails, and it is better than throwing an exception.
  User must specify the ContentType to get the right results.}
  {CC4: removed addition of boundaries; now added at GenerateHeader stage (could
  end up with boundary added more than once)}
  if AMsg.ContentType = '' then begin
    if AMsg.MessageParts.RelatedPartCount > 0 then begin
      AMsg.ContentType
       := 'multipart/related; type="multipart/alternative"';  //; boundary="' + {do not localize}
       //IdMIMEBoundaryStrings.IndyMIMEBoundary + '"';    {Do not Localize}
    end else begin
      if AMsg.MessageParts.AttachmentCount > 0 then begin
        AMsg.ContentType := 'multipart/mixed'; //; boundary="' {do not localize}
         //+ IdMIMEBoundaryStrings.IndyMIMEBoundary + '"';    {Do not Localize}
      end else begin
        if AMsg.MessageParts.TextPartCount > 0 then begin
          AMsg.ContentType :=
           'multipart/alternative';  //; boundary="' {do not localize}
           //+ IdMIMEBoundaryStrings.IndyMIMEBoundary + '"';    {Do not Localize}
        end;
      end;
    end;
  end;
end;

{ TIdMessageEncoderMIME }

procedure TIdMessageEncoderMIME.Encode(ASrc, ADest: TStream);
var
  s: string;
  LEncoder: TIdEncoderMIME;
  LSPos, LSSize : Int64;
begin
  ASrc.Position := 0;
  LSPos := 0;
  LSSize := ASrc.Size;
  LEncoder := TIdEncoderMIME.Create(nil); try
    while LSPos < LSSize do begin
      s := LEncoder.Encode(ASrc, 57) + EOL;
      Inc(LSPos,57);
      WriteStringToStream(ADest, s);
    end;
  finally FreeAndNil(LEncoder); end;
end;

initialization
  TIdMessageDecoderList.RegisterDecoder('MIME'    {Do not Localize}
   , TIdMessageDecoderInfoMIME.Create);
  TIdMessageEncoderList.RegisterEncoder('MIME'    {Do not Localize}
   , TIdMessageEncoderInfoMIME.Create);
  IdMIMEBoundaryStrings := TIdMIMEBoundaryStrings.Create;
finalization
  IdMIMEBoundaryStrings.Free;
  IdMIMEBoundaryStrings := nil;  {Global vars always initialised to 0, not nil}
end.
