-- -- -- package Copyright (c) Dmitry A. Kazakov -- -- GNAT.Sockets.SMTP.Client Luebeck -- -- Implementation Summer, 2016 -- -- -- -- Last revision : 13:13 14 Sep 2019 -- -- -- -- This library is free software; you can redistribute it and/or -- -- modify it under the terms of the GNU General Public License as -- -- published by the Free Software Foundation; either version 2 of -- -- the License, or (at your option) any later version. This library -- -- is distributed in the hope that it will be useful, but WITHOUT -- -- ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- General Public License for more details. You should have -- -- received a copy of the GNU General Public License along with -- -- this library; if not, write _ the Free Software Foundation, -- -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from -- -- this unit, or you link this unit with other files to produce an -- -- executable, this unit does not by itself cause the resulting -- -- executable to be covered by the GNU General Public License. This -- -- exception does not however invalidate any other reasons why the -- -- executable file might be covered by the GNU Public License. -- --____________________________________________________________________-- with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; with Ada.Exceptions; use Ada.Exceptions; with Ada.IO_Exceptions; use Ada.IO_Exceptions; with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; with Strings_Edit; use Strings_Edit; with Strings_Edit.Base64; use Strings_Edit.Base64; with Strings_Edit.Integers; use Strings_Edit.Integers; with Strings_Edit.Quoted; use Strings_Edit.Quoted; with Strings_Edit.UTF8.Mapping; use Strings_Edit.UTF8.Mapping; with Ada.Numerics.Discrete_Random; with Ada.Unchecked_Deallocation; with GNAT.MD5; package body GNAT.Sockets.SMTP.Client is use Mail_Handles; use Object; Opad : constant Stream_Element := 16#5C#; Ipad : constant Stream_Element := 16#36#; Encoded_Length : constant := 72; Chunk_Length : constant := (Encoded_Length * 3 + 3) / 4; CRLF : constant String := CR & LF; Colon : constant String := ":" ; Dot : constant String := "." ; LF_Dot : constant String := LF & "."; Data_End : constant String := CRLF & "." & CRLF; Multipart_End : constant String := "--" & CRLF & Data_End; Boundary : constant String := -- 1234567890123456 CRLF & CRLF & "--[message part]" & CRLF; package Random_UID is new Ada.Numerics.Discrete_Random (Interfaces.Unsigned_64); Dice : Random_UID.Generator; procedure Free is new Ada.Unchecked_Deallocation ( Attachment_Object'Class, Attachment_Object_Ptr ); procedure Free is new Ada.Unchecked_Deallocation ( Root_Stream_Type'Class, Stream_Ptr ); procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr); -- function "abs" (Name : String) return String is -- Length : Natural := 0; -- begin -- for Index in Name'Range loop -- case Name (Index) is -- when 'A'..'Z' | 'a'..'z' | '0'..'9' | -- '-' | '_' | '.' | '!' | '~' | '*' | ''' | '(' | ')' => -- Length := Length + 1; -- when others => -- Length := Length + 3; -- end case; -- end loop; -- declare -- Pointer : Integer := 1; -- Result : String (1..Length); -- begin -- for Index in Name'Range loop -- case Name (Index) is -- when 'A'..'Z' | 'a'..'z' | '0'..'9' | -- '-' | '_' | '.' | '!' | '~' | '*' | -- ''' | '(' | ')' => -- Result (Pointer) := Name (Index); -- Pointer := Pointer + 1; -- when others => -- Result (Pointer) := '%'; -- Pointer := Pointer + 1; -- Strings_Edit.Integers.Put -- ( Destination => Result, -- Pointer => Pointer, -- Value => Character'Pos (Name (Index)), -- Base => 16, -- Field => 2, -- Justify => Right, -- Fill => '0' -- ); -- end case; -- end loop; -- return Result; -- end; -- end "abs"; procedure Add_Address ( List : in out Mail_Address_List; Address : String ) is use Persistent.Catalogue; Text : constant String := Trim (Address); begin if Text'Length > 0 then Add (List.Set, Address); end if; end Add_Address; procedure Append ( Object : in out Mail_Object; Attachment : Attachment_Object_Ptr ) is begin if Object.First = null then Object.First := Attachment; else Object.Last.Next := Attachment; end if; Object.Last := Attachment; end Append; procedure Attach_File ( Message : in out Mail; Contents : String; Content_Type : String := "text/plain"; Disposition : String := ""; Description : String := "" ) is Attachment : Attachment_Object_Ptr; begin if not Is_Valid (Message.Reference) then Raise_Exception ( Use_Error'Identity, "Attaching to an uninitialized mail message" ); end if; declare Object : Mail_Object'Class renames Ptr (Message.Reference).all; Header : constant String := Get_Content_Type (Content_Type) & Get_Content_Disposition (Disposition) & Get_Content_Description (Description) & "Content-Transfer-Encoding: base64" & CRLF & CRLF; begin Set_MIME (Object); Attachment := new Attachment_File ( Name_Length => Contents'Length, Header_Length => Header'Length ); Attachment.Header := Header; declare This : Attachment_File renames Attachment_File (Attachment.all); begin This.Name := Contents; Stream_IO.Open (This.File, Stream_IO.In_File, Contents); This.Open := True; exception when others => Free (Attachment); raise; end; Append (Object, Attachment); end; end Attach_File; procedure Attach_Stream ( Message : in out Mail; Contents : access Root_Stream_Type'Class; Content_Type : String := "text/plain"; Disposition : String := ""; Description : String := "" ) is begin if not Is_Valid (Message.Reference) then Raise_Exception ( Use_Error'Identity, "Attaching to an uninitialized mail message" ); end if; declare Object : Mail_Object'Class renames Ptr (Message.Reference).all; begin Set_MIME (Object); Append ( Object, Create_Stream_Attachment ( Contents => Contents.all'Unchecked_Access, Owned => True, Content_Type => Content_Type, Disposition => Disposition, Description => Description ) ); end; end Attach_Stream; procedure Attach_Stream ( Message : in out Mail; Contents : in out Root_Stream_Type'Class; Content_Type : String := "text/plain"; Disposition : String := ""; Description : String := "" ) is begin if not Is_Valid (Message.Reference) then Raise_Exception ( Use_Error'Identity, "Attaching to an uninitialized mail message" ); end if; declare Object : Mail_Object'Class renames Ptr (Message.Reference).all; begin Set_MIME (Object); Append ( Object, Create_Stream_Attachment ( Contents => Contents'Unchecked_Access, Owned => False, Content_Type => Content_Type, Disposition => Disposition, Description => Description ) ); end; end Attach_Stream; procedure Attach_String ( Message : in out Mail; Contents : String; Content_Type : String := "text/plain"; Disposition : String := ""; Description : String := "" ) is begin if not Is_Valid (Message.Reference) then Raise_Exception ( Use_Error'Identity, "Attaching to an uninitialized mail message" ); end if; declare Object : Mail_Object'Class renames Ptr (Message.Reference).all; begin Set_MIME (Object); Append ( Object, Create_String_Attachment ( Contents => Contents, Content_Type => Content_Type, Disposition => Disposition, Description => Description ) ); end; end Attach_String; procedure Check (Message : Mail) is begin if not Is_Valid (Message.Reference) then Raise_Exception (Use_Error'Identity, "Empty mail message"); end if; declare Object : Mail_Object'Class renames Ptr (Message.Reference).all; begin if Object.Next /= null then Raise_Exception ( Use_Error'Identity, "The mail message is already queued" ); elsif ( ( Object.Contents = null or else Object.Contents'Length = 0 ) and then Object.First = null ) then Raise_Exception ( Use_Error'Identity, "Missing message body" ); elsif ( Object.Texts (Mail_From) = null or else Object.Texts (Mail_From)'Length = 0 ) then Raise_Exception ( Use_Error'Identity, "Missing sender's address" ); elsif ( Object.Texts (Mail_Subject) = null or else Object.Texts (Mail_Subject)'Length = 0 ) then Raise_Exception (Use_Error'Identity, "Missing subject"); elsif Is_Empty (Object.Addresses (Mail_To)) then Raise_Exception ( Use_Error'Identity, "Missing recipient's address" ); end if; end; end Check; procedure Close (Attachment : in out Attachment_Object) is begin null; end Close; procedure Close (Attachment : in out Attachment_File) is begin if Attachment.Open then Attachment.Open := False; begin Stream_IO.Close (Attachment.File); exception when others => null; end; end if; end Close; procedure Completed (Client : in out SMTP_Client) is begin null; end Completed; procedure Connected (Client : in out SMTP_Client) is begin Client.Command := SMTP_Greeting; Client.Receive_State := Receive_Code; Client.Send_State := Send_Command; Client.Count := 0; Client.Authentication := 0; Client.Mail_Size := Natural'Last; Client.Offered_TLS := False; Client.Extensions := (others => False); Connected (Connection (Client)); Connected (Connection (Client)); end Connected; function CRAM_MD5 (User, Password, Challenge : String) return String is use GNAT.MD5; function "xor" (Text : String; Pad : Stream_Element) return String is Result : String (Text'Range); begin for Index in Result'Range loop Result (Index) := Character'Val (Character'Pos (Text (Index)) xor Pad); end loop; return Result; end "xor"; Secret : String := (1..64 => NUL); begin if Password'Length <= Secret'Length then Secret (1..Password'Length) := Password; else Secret (1..16) := To_String (Digest (Password)); end if; return To_Base64 ( User & ' ' & Digest ( (Secret xor Opad) & To_String (Digest ((Secret xor Ipad) & Challenge)) ) ); end CRAM_MD5; function Cnonce return String is use Interfaces; use Random_UID; use GNAT.MD5; Value : constant Unsigned_64 := Random (Dice); Result : constant String := ( 1 => Character'Val ( Value mod 2**8), 2 => Character'Val ((Value / 2**8 ) mod 2**8), 3 => Character'Val ((Value / 2**16) mod 2**8), 4 => Character'Val ((Value / 2**24) mod 2**8), 5 => Character'Val ((Value / 2**32) mod 2**8), 6 => Character'Val ((Value / 2**40) mod 2**8), 7 => Character'Val ((Value / 2**48) mod 2**8), 8 => Character'Val ( Value / 2**56) ); Encode : constant String := Digest (Result); begin return Encode (Encode'First..Encode'First + 13); end Cnonce; function DIGEST_MD5 ( Host : String; User : String; Password : String; Challenge : String; Request : String; Cnonce : String ) return String is use GNAT.MD5; Method : constant String := "AUTHENTICATE"; QOP : constant String := "auth"; Nc : constant String := "00000001"; Pointer : Integer := Challenge'First; Topic : SMTP_Challenge; From : array (SMTP_Challenge) of Integer := (others => Challenge'First); To : array (SMTP_Challenge) of Integer := (others => Challenge'First - 1); function Nonce return String is begin return Challenge (From (SMTP_NONCE)..To (SMTP_NONCE)); end Nonce; function Realm return String is begin if From (SMTP_REALM) <= To (SMTP_REALM) then return Challenge (From (SMTP_REALM)..To (SMTP_REALM)); else return Host; end if; end Realm; function URI return String is begin return Request & '/' & Realm; end URI; function A1 return String is begin if ( To_Lowercase ( Challenge ( From (SMTP_ALGORITHM) .. To (SMTP_ALGORITHM) ) ) = "md5-sess" ) then return ( To_String (Digest (User & ':' & Realm & ':' & Password)) & ':' & Nonce & ':' & Cnonce ); else return User & ':' & Realm & ':' & Password; end if; end A1; function A2 return String is QOP : constant String := To_Lowercase ( Challenge (From (SMTP_QOP)..To (SMTP_QOP)) ); begin if QOP = "auth-int" or else QOP = "auth-conf" then return ( Method & ':' & URI & ":00000000000000000000000000000000" ); else return Method & ':' & URI; end if; end A2; begin while Pointer <= Challenge'Last loop Get (Challenge, Pointer); exit when Pointer > Challenge'Last; declare Got_It : Boolean; begin Get (Challenge, Pointer, Challenges, Topic, Got_It); if not Got_It then Raise_Exception ( Data_Error'Identity, "Invalid digest-md5 challenge, unsupported " & "topic at " & Challenge (Pointer..Challenge'Last) ); end if; end; Get (Challenge, Pointer); if Pointer > Challenge'Last or else Challenge (Pointer) /= '=' then Raise_Exception ( Data_Error'Identity, "Invalid digest-md5 challenge, '=' is expected after " & "a keyword at " & Challenge (Pointer..Challenge'Last) ); end if; Pointer := Pointer + 1; Get (Challenge, Pointer); if Pointer > Challenge'Last then Raise_Exception ( Data_Error'Identity, "Invalid digest-md5 challenge, topic value is " & "expected after equality sign at " & Challenge (Pointer..Challenge'Last) ); end if; if Challenge (Pointer) = '"' then Pointer := Pointer + 1; From (Topic) := Pointer; while Pointer <= Challenge'Last loop if Challenge (Pointer) = '"' then To (Topic) := Pointer - 1; exit; end if; Pointer := Pointer + 1; end loop; if Pointer > Challenge'Last then Raise_Exception ( Data_Error'Identity, "Invalid digest-md5 challenge, missing closing " & "quotation marks" ); end if; Pointer := Pointer + 1; else From (Topic) := Pointer; loop if Pointer > Challenge'Last then To (Topic) := Pointer - 1; exit; end if; case Challenge (Pointer) is when ' ' | ',' | Character'Val (9) => To (Topic) := Pointer - 1; exit; when others => Pointer := Pointer + 1; end case; end loop; end if; Get (Challenge, Pointer); exit when Pointer > Challenge'Last; if Challenge (Pointer) /= ',' then Raise_Exception ( Data_Error'Identity, "Invalid digest-md5 challenge, ',' is expected at " & Challenge (Pointer..Challenge'Last) ); end if; Pointer := Pointer + 1; end loop; declare Response : constant String := Digest ( Digest (A1) & ':' & Nonce & ':' & Nc & ':' & Cnonce & ':' & QOP & ':' & Digest (A2) ); begin declare Decoded : constant String := ( "charset=utf-8," & "username=""" & User & """,realm=""" & Realm & """,nonce=""" & Nonce & """,nc=" & Nc & ",cnonce=""" & Cnonce & """,digest-uri=""" & URI & """,response=" & Response & ",qop=" & QOP ); begin return To_Base64 (Decoded); end; end; end DIGEST_MD5; function Create ( From : String; Subject : String; To : Mail_Address_List'Class; Contents : String; Cc : Mail_Address_List'Class := Empty; Bcc : Mail_Address_List'Class := Empty; Date : Time := Clock; MIME : String := "text/plain" ) return Mail is Result : Mail; begin Set (Result.Reference, new Mail_Object); declare Object : Mail_Object'Class renames Ptr (Result.Reference).all; begin Object.Texts (Mail_From) := new String'(Trim (From)); Object.Addresses (Mail_To).Set := To.Set; Object.Addresses (Mail_Cc).Set := Cc.Set; Object.Addresses (Mail_Bcc).Set := Bcc.Set; Object.Texts (Mail_Subject) := new String'(Subject); Object.Dates (Mail_Date) := Date; if MIME'Length > 0 then Set_MIME (Object); Prepend (Object, Create_String_Attachment (Contents, MIME)); else Object.Contents := new String'(Contents); end if; end; return Result; end Create; function Create ( From : String; Subject : String; To : String; Contents : String; Cc : Mail_Address_List'Class := Empty; Bcc : Mail_Address_List'Class := Empty; Date : Time := Clock; MIME : String := "text/plain" ) return Mail is begin return Create ( From => From, Subject => Subject, To => Empty / To, Contents => Contents, Cc => Cc, Bcc => Bcc, Date => Date, MIME => MIME ); end Create; function Create ( From : String; Subject : String; To : Mail_Address_List'Class; Cc : Mail_Address_List'Class := Empty; Bcc : Mail_Address_List'Class := Empty; Date : Time := Clock ) return Mail is Result : Mail; begin Set (Result.Reference, new Mail_Object); declare Object : Mail_Object'Class renames Ptr (Result.Reference).all; begin Object.Texts (Mail_From) := new String'(Trim (From)); Object.Addresses (Mail_To).Set := To.Set; Object.Addresses (Mail_Cc).Set := Cc.Set; Object.Addresses (Mail_Bcc).Set := Bcc.Set; Object.Texts (Mail_Subject) := new String'(Subject); Object.Dates (Mail_Date) := Date; end; return Result; end Create; function Create ( From : String; Subject : String; To : String; Cc : Mail_Address_List'Class := Empty; Bcc : Mail_Address_List'Class := Empty; Date : Time := Clock ) return Mail is begin return Create ( From => From, Subject => Subject, To => Empty / To, Cc => Cc, Bcc => Bcc, Date => Date ); end Create; function Create_Stream_Attachment ( Contents : Stream_Ptr; Owned : Boolean; Content_Type : String := "text/plain"; Disposition : String := ""; Description : String := "" ) return Attachment_Object_Ptr is Result : Attachment_Object_Ptr; Header : constant String := Get_Content_Type (Content_Type) & Get_Content_Disposition (Disposition) & Get_Content_Description (Description) & "Content-Transfer-Encoding: base64" & CRLF & CRLF; begin Result := new Attachment_Stream (Header'Length); Result.Header := Header; declare Object : Attachment_Stream renames Attachment_Stream (Result.all); begin Object.Owned := Owned; Object.Stream := Contents; end; return Result; end Create_Stream_Attachment; function Create_String_Attachment ( Contents : String; Content_Type : String := "text/plain"; Disposition : String := ""; Description : String := "" ) return Attachment_Object_Ptr is Result : Attachment_Object_Ptr; Header : constant String := Get_Content_Type (Content_Type) & Get_Content_Disposition (Disposition) & Get_Content_Description (Description) & "Content-Transfer-Encoding: base64" & CRLF & CRLF; begin Result := new Attachment_String ( Length => Contents'Length, Header_Length => Header'Length ); Result.Header := Header; Attachment_String (Result.all).Buffer := Contents; return Result; end Create_String_Attachment; procedure Delete (Message : in out Mail_Object_Ptr) is begin if Message /= null then declare This : Mail_Object_Ptr := Message; Empty : constant Boolean := This.Next = This; begin if Empty then -- Empty queue Message := null; else Message := This.Next; end if; This.Previous.Next := This.Next; This.Next.Previous := This.Previous; This.Previous := null; This.Next := null; Release (Entity_Ptr (This)); end; end if; end Delete; procedure Disconnected (Client : in out SMTP_Client) is This : Mail_Object_Ptr := Client.Queue; Count : Natural := 0; begin if This /= null then loop Count := Count + 1; This := This.Next; exit when This = Client.Queue; end loop; declare Unsent : Mail_Array (1..Count); begin for Index in Unsent'Range loop Unsent (Index) := (Reference => Ref (Client.Queue)); Delete (Client.Queue); end loop; Send_Abandoned (SMTP_Client'Class (Client), Unsent); end; end if; Disconnected (Connection (Client)); end Disconnected; procedure Do_Quit (Client : in out SMTP_Client'Class) is begin Client.Command := SMTP_QUIT; Client.Send_State := Send_Command; Client.Receive_State := Receive_Code; Client.Count := 0; Send_Text (Client, "QUIT" & CRLF); end Do_Quit; procedure Elevated (Client : in out SMTP_Client) is begin Client.Command := SMTP_EHLO; Send_Text ( Client, ( "EHLO " & Official_Name (Get_Host_By_Name (Host_Name)) & CRLF ) ); end Elevated; function Empty return Mail_Address_List is use Persistent.Catalogue; Result : Mail_Address_List; begin return Result; end Empty; procedure Erase (Object : in out Mail_Object) is begin Object.Status := Mail_Pending; for Index in Object.Texts'Range loop Free (Object.Texts (Index)); end loop; for Index in Object.Addresses'Range loop Object.Addresses (Index) := Empty; end loop; Free (Object.Contents); Object.Last := null; while Object.First /= null loop declare This : Attachment_Object_Ptr := Object.First; begin Object.First := This.Next; Free (This); end; end loop; end Erase; procedure Erase (Message : in out Mail) is begin if Is_Valid (Message.Reference) then Erase (Ptr (Message.Reference).all); end if; end Erase; procedure Finalize (Object : in out Mail_Object) is begin if Object.Next /= null then Raise_Exception ( Program_Error'Identity, "Premature destruction of a queued mail object" ); end if; Erase (Object); end Finalize; procedure Finalize (Attachment : in out Attachment_Stream) is begin if Attachment.Owned then Free (Attachment.Stream); end if; Finalize (Attachment_Object (Attachment)); end Finalize; procedure Finalize (Attachment : in out Attachment_File) is begin Close (Attachment); Finalize (Attachment_Object (Attachment)); end Finalize; procedure Finalize (Client : in out SMTP_Client) is begin while Client.Queue /= null loop Delete (Client.Queue); end loop; Free (Client.Encoded); Free (Client.User); Free (Client.Password); Finalize (Connection (Client)); end Finalize; function Find ( List : Mail_Address_List; Address : String ) return Natural is use Persistent.Catalogue; begin return Find (List.Set, Trim (Address)); end Find; function From_String (List : String) return Mail_Address_List is use Persistent.Catalogue; Result : Mail_Address_List; Start : Integer := List'First; begin for Index in List'Range loop if List (Index) = ',' then Add_Address (Result, List (Start..Index - 1)); Start := Index + 1; end if; end loop; Add_Address (Result, List (Start..List'Last)); return Result; end From_String; function Get ( Message : Mail_Object'Class; Header : Text_Header ) return String is begin if Message.Texts (Header) = null then return ""; else return Message.Texts (Header).all; end if; end Get; function Get ( Message : Mail_Object'Class; Header : List_Header ) return Mail_Address_List is begin return (Set => Message.Addresses (Header).Set); end Get; function Get ( Message : Mail_Object'Class; Header : Date_Header ) return Time is begin return Message.Dates (Header); end Get; function Get ( Message : Mail; Header : Text_Header ) return String is begin if not Is_Valid (Message.Reference) then return ""; else return Get (Ptr (Message.Reference).all, Header); end if; end Get; function Get ( Message : Mail; Header : List_Header ) return Mail_Address_List is begin if not Is_Valid (Message.Reference) then return Empty; else return Get (Ptr (Message.Reference).all, Header); end if; end Get; function Get ( Message : Mail; Header : Date_Header ) return Time is begin if Is_Valid (Message.Reference) then return Get (Ptr (Message.Reference).all, Header); else Raise_Exception ( Constraint_Error'Identity, "Uninitialized object" ); end if; end Get; function Get_Address ( List : Mail_Address_List; Index : Positive ) return String is use Persistent.Catalogue; begin return Get (List.Set, Index); end Get_Address; function Get_Accepted ( Client : SMTP_Client ) return SMTP_AUTH_Mechanism is begin return Client.Supported; end Get_Accepted; function Get_Authentication ( Client : SMTP_Client ) return SMTP_AUTH_Mechanism is begin return Client.Authentication; end Get_Authentication; function Get_Content_Type (Value : String) return String is begin if Value'Length = 0 then return ""; else return "Content-Type: " & Value & CRLF; end if; end Get_Content_Type; function Get_Content_Disposition (Value : String) return String is begin if Value'Length = 0 then return ""; else return "Content-Disposition: attachment; " & Value & CRLF; end if; end Get_Content_Disposition; function Get_Content_Description (Value : String) return String is begin if Value'Length = 0 then return ""; else return "Content-Description: " & Value & CRLF; end if; end Get_Content_Description; function Get_Enhanced (Client : SMTP_Client) return Boolean is begin return Client.Force_ESMTP; end Get_Enhanced; function Get_Extension ( Client : SMTP_Client; Extension : SMTP_Extension ) return Boolean is begin return Client.Extensions (Extension); end Get_Extension; function Get_Length (List : Mail_Address_List) return Natural is use Persistent.Catalogue; begin return Get_Size (List.Set); end Get_Length; function Get_Mail_Size (Client : SMTP_Client) return Natural is begin return Client.Mail_Size; end Get_Mail_Size; function Get_Password (Client : SMTP_Client) return String is begin return Value (Client.Password); end Get_Password; function Get_Status (Message : Mail) return Mail_Status is begin if Is_Valid (Message.Reference) then return Ptr (Message.Reference).Status; else return Mail_Pending; end if; end Get_Status; function Get_TLS (Client : SMTP_Client) return Boolean is begin return Client.Accept_TLS; end Get_TLS; function Get_TLS_Always (Client : SMTP_Client) return Boolean is begin return Client.Force_TLS; end Get_TLS_Always; function Get_User (Client : SMTP_Client) return String is begin return Value (Client.User); end Get_User; function Image (Header : Mail_Header) return String is begin case Header is when Mail_Message_ID => return "Message-ID"; when Mail_In_Reply_To => return "In-Reply-To"; when Mail_Subject => return "Subject"; when Mail_MIME_Version => return "MIME-Version"; when Mail_Content_Type => return "Content-Type"; when Mail_Precedence => return "Predecence"; when Mail_References => return "References"; when Mail_Reply_To => return "Reply-To"; when Mail_Sender => return "Sender"; when Mail_Archived_At => return "Archived-At"; when Mail_To => return "To"; when Mail_From => return "From"; when Mail_Bcc => return "Bcc"; when Mail_Cc => return "Cc"; when Mail_Date => return "Date"; when Mail_Body => return "Body"; end case; end Image; function Image (List : Mail_Address_List) return String is use Persistent.Catalogue; Length : Natural := 0; begin for Index in 1..Get_Size (List.Set) loop Length := Length + Get (List.Set, Index)'Length; end loop; if Length = 0 then return ""; end if; declare Result : String (1..Length + Get_Size (List.Set) - 1); Pointer : Integer := Result'First; begin for Index in 1..Get_Size (List.Set) loop if Index > 1 then Put (Result, Pointer, ","); end if; Put (Result, Pointer, Get (List.Set, Index)); end loop; return Result; end; end Image; function Is_Empty (List : Mail_Address_List) return Boolean is use Persistent.Catalogue; begin return Get_Size (List.Set) = 0; end Is_Empty; function Is_In ( List : Mail_Address_List; Address : String ) return Boolean is use Persistent.Catalogue; begin return Is_In (List.Set, Trim (Address)); end Is_In; function Is_Opportunistic (Client : SMTP_Client) return Boolean is begin return True; end Is_Opportunistic; procedure On_Auth (Client : in out SMTP_Client'Class) is begin if Client.Authentication >= SMTP_DIGEST_MD5 then case Client.Index is when 1 => Client.Index := 2; Send_Text ( Client, ( DIGEST_MD5 ( Image (Client.Get_Client_Address.Addr), Value (Client.User), Value (Client.Password), From_Base64 ( Client.Reply (1..Client.Pointer - 1) ), "smtp", Cnonce ) & CRLF ) ); when others => Client.Command := SMTP_MAIL; On_Mail (Client); end case; elsif Client.Authentication >= SMTP_CRAM_MD5 then case Client.Index is when 1 => Client.Index := 2; Send_Text ( Client, ( CRAM_MD5 ( Value (Client.User), Value (Client.Password), From_Base64 ( Client.Reply (1..Client.Pointer - 1) ) ) & CRLF ) ); when others => Client.Command := SMTP_MAIL; On_Mail (Client); end case; elsif Client.Authentication >= SMTP_LOGIN then case Client.Index is when 1 => Client.Index := 2; Send_Text ( Client, To_Base64 (Value (Client.User)) & CRLF ); when 2 => Client.Index := 3; Send_Text ( Client, To_Base64 (Value (Client.Password)) & CRLF ); when others => Client.Command := SMTP_MAIL; On_Mail (Client); end case; else -- Success Client.Command := SMTP_MAIL; On_Mail (Client); end if; end On_Auth; procedure On_Content_End ( Client : in out SMTP_Client'Class; Message : in out Mail_Object'Class ) is begin if Message.First = null then Client.Send_State := Send_Data_End; Client.Index := Data_End'First; else Client.Send_State := Send_Boundary_Middle; Client.Attachment := Message.First; Client.Index := Boundary'First; end if; end On_Content_End; procedure On_EHLO_Response ( Client : in out SMTP_Client'Class; Reply : String ) is Got_It : Boolean; Flag : SMTP_Extension; Pointer : Integer := Reply'First; begin Get (Reply, Pointer, Extensions, Flag, Got_It); if not Got_It then return; -- Ignore unrecognized end if; Client.Extensions (Flag) := True; case Flag is when SMTP_AUTH => declare Mode : SMTP_AUTH_Mechanism; begin loop Get (Reply, Pointer); exit when Pointer > Reply'Last; begin Get (Reply, Pointer, Authentications, Mode); Client.Authentication := Client.Authentication or Mode; exception when End_Error => -- Skip an unsupported method loop case Reply (Pointer) is when ' ' | Character'Val (9) => Pointer := Pointer + 1; exit; when others => Pointer := Pointer + 1; end case; exit when Pointer > Reply'Last; end loop; end; end loop; exception when others => null; end; when SMTP_SIZE => begin Get (Reply, Pointer); Get (Reply, Pointer, Client.Mail_Size, First => 1); exception when others => Client.Mail_Size := Natural'Last; end; when SMTP_STARTTLS => Client.Offered_TLS := True; when others => null; end case; exception when others => -- Ignore unrecognized null; end On_EHLO_Response; procedure On_Greeting ( Client : in out SMTP_Client'Class; Code : Error_Code; Reply : String ) is begin if Client.Force_ESMTP then Client.ESMTP := True; else declare Start : Boolean := True; begin Client.ESMTP := False; for Index in Reply'Range loop if ( Start and then Is_Prefix ("esmtp", Reply, Index, Lower_Case_Map) and then ( Index + 5 > Reply'Last or else Reply (Index + 5) = ' ' ) ) then Client.ESMTP := True; exit; end if; Start := Reply (Index) = ' '; end loop; end; end if; Client.Receive_State := Receive_Code; Client.Count := 0; if Client.ESMTP then Client.Command := SMTP_EHLO; Send_Text ( Client, ( "EHLO " & Official_Name (Get_Host_By_Name (Host_Name)) & CRLF ) ); else Client.Command := SMTP_HELO; Send_Text ( Client, ( "HELO " & Official_Name (Get_Host_By_Name (Host_Name)) & CRLF ) ); end if; end On_Greeting; procedure On_Mail (Client : in out SMTP_Client'Class) is begin if Client.Queue = null then Completed (Client); if Client.Queue = null then Do_Quit (Client); return; end if; elsif Client.Command = SMTP_EHLO then if ( ( Client.Force_TLS or else (Client.Offered_TLS and then Client.Accept_TLS) ) and then Is_TLS_Capable (Client.Listener.Factory.all) and then not Is_Elevated (Client) ) then -- Go TLS Client.Command := SMTP_STARTTLS; Client.Receive_State := Receive_Code; Client.Count := 0; Send_Text (Client, "STARTTLS" & CRLF); return; else -- Use authentication Client.Authentication := Client.Authentication and Client.Supported; if Client.Authentication >= SMTP_DIGEST_MD5 then Client.Authentication := SMTP_DIGEST_MD5; Client.Command := SMTP_AUTH; Send_Text (Client, "AUTH DIGEST-MD5" & CRLF); Client.Send_State := Send_Command; Client.Receive_State := Receive_Code; Client.Count := 0; Client.Index := 1; return; elsif Client.Authentication >= SMTP_CRAM_MD5 then Client.Authentication := SMTP_CRAM_MD5; Client.Command := SMTP_AUTH; Send_Text (Client, "AUTH CRAM-MD5" & CRLF); Client.Send_State := Send_Command; Client.Receive_State := Receive_Code; Client.Count := 0; Client.Index := 1; return; elsif Client.Authentication >= SMTP_LOGIN then Client.Authentication := SMTP_LOGIN; Client.Command := SMTP_AUTH; Send_Text (Client, "AUTH LOGIN" & CRLF); Client.Send_State := Send_Command; Client.Receive_State := Receive_Code; Client.Count := 0; Client.Index := 1; return; elsif Client.Authentication = SMTP_PLAIN then Client.Command := SMTP_AUTH; Send_Text ( Client, ( "AUTH PLAIN " & To_Base64 ( NUL & Value (Client.User) & NUL & Value (Client.Password) ) & CRLF ) ); Client.Send_State := Send_Command; Client.Receive_State := Receive_Code; Client.Count := 0; return; end if; end if; end if; declare Message : Mail_Object'Class renames Client.Queue.all; begin Client.Command := SMTP_MAIL; Client.Send_State := Send_Command; Client.Receive_State := Receive_Code; Client.Count := 0; Send_Text ( Client, "MAIL FROM:" & Get (Message, Mail_From) & CRLF ); end; end On_Mail; procedure On_Recipient (Client : in out SMTP_Client'Class) is begin if Client.Queue = null then Completed (Client); if Client.Queue = null then Do_Quit (Client); return; end if; end if; declare Message : Mail_Object'Class renames Client.Queue.all; List : Mail_Address_List; begin loop List := Get (Message, Client.Header); Client.Index := Client.Index + 1; if Client.Index > Get_Length (List) then case Client.Header is when Mail_To => Client.Header := Mail_Bcc; Client.Index := 0; when Mail_Bcc => Client.Header := Mail_Cc; Client.Index := 0; when Mail_Cc => Client.Command := SMTP_DATA; Client.Receive_State := Receive_Code; Client.Count := 0; Client.Header := Mail_Header'First; Send_Text (Client, "DATA" & CRLF); return; when others => Raise_Exception ( Data_Error'Identity, ( "Internal error, " & "wrong address type" ) ); end case; else Client.Receive_State := Receive_Code; Client.Count := 0; Send_Text ( Client, "RCPT TO:" & Get_Address (List, Client.Index) & CRLF ); return; end if; end loop; end; end On_Recipient; procedure On_Reply_Error (Client : in out SMTP_Client'Class) is begin case Client.Command is when SMTP_HELO | SMTP_EHLO | SMTP_RSET | SMTP_Sent | SMTP_HELP | SMTP_NOOP | SMTP_QUIT | SMTP_AUTH | SMTP_STARTTLS | SMTP_Greeting => Send_Error ( Client, Client.Code, Client.Command, Client.Reply (1..Client.Pointer - 1) ); raise Connection_Error; when SMTP_MAIL | SMTP_RCPT | SMTP_DATA => if Client.Queue = null then Send_Error ( Client, Client.Code, Client.Command, Client.Reply (1..Client.Pointer - 1) ); raise Connection_Error; else Client.Queue.Status := Mail_Rejected; Send_Error ( Client, Client.Code, Client.Command, Client.Reply (1..Client.Pointer - 1), (Reference => Ref (Client.Queue)) ); Delete (Client.Queue); On_Mail (Client); end if; end case; end On_Reply_Error; procedure Prepend ( Object : in out Mail_Object; Attachment : Attachment_Object_Ptr ) is begin Attachment.Next := Object.First; if Object.First = null then Object.Last := Attachment; end if; Object.First := Attachment; end Prepend; procedure Read ( Attachment : in out Attachment_String; Buffer : in out Stream_Element_Array; Last : out Stream_Element_Offset ) is Size : Integer := Attachment.Length - Attachment.Index + 1; begin Last := Buffer'First - 1; if Size > 0 then if Size > Buffer'Length then Size := Buffer'Length; end if; for Index in Attachment.Index..Attachment.Index + Size - 1 loop Last := Last + 1; Buffer (Last) := Character'Pos (Attachment.Buffer (Index)); end loop; Attachment.Index := Attachment.Index + Size; end if; end Read; procedure Read ( Attachment : in out Attachment_Stream; Buffer : in out Stream_Element_Array; Last : out Stream_Element_Offset ) is begin Read (Attachment.Stream.all, Buffer, Last); exception when End_Error => Last := Buffer'First - 1; end Read; procedure Read ( Attachment : in out Attachment_File; Buffer : in out Stream_Element_Array; Last : out Stream_Element_Offset ) is begin Stream_IO.Read (Attachment.File, Buffer, Last); if Last < Buffer'First then Stream_IO.Close (Attachment.File); Attachment.Open := False; end if; exception when End_Error => Stream_IO.Close (Attachment.File); Attachment.Open := False; Last := Buffer'First - 1; when Error : others => Raise_Exception ( Data_Error'Identity, ( "Error reading attached file " & Quote (Attachment.Name) & ": " & Exception_Message (Error) ) ); end Read; procedure Received ( Client : in out SMTP_Client; Data : Stream_Element_Array; Pointer : in out Stream_Element_Offset ) is begin Pointer := Data'First; if Client.Send_State /= Send_Command then Raise_Exception ( Data_Error'Identity, ( "Unsolicited response while sending state is " & SMTP_Send_State'Image (Client.Send_State) ) ); end if; while Pointer <= Data'Last loop case Client.Receive_State is when Receive_Code => loop case Data (Pointer) is when Character'Pos ('0')..Character'Pos ('9') => if Client.Count = 0 then Client.Pointer := Integer (Data (Pointer)) - Character'Pos ('0'); elsif Client.Count > 2 then Raise_Exception ( Data_Error'Identity, "Invalid reply code, longer than 3 digits" ); else Client.Pointer := Client.Pointer * 10 + Integer (Data (Pointer)) - Character'Pos ('0'); end if; Client.Count := Client.Count + 1; Pointer := Pointer + 1; when Character'Pos (' ') => if Client.Count = 0 then Raise_Exception ( Data_Error'Identity, "Missing reply code" ); elsif Client.Pointer not in 200..554 then Raise_Exception ( Data_Error'Identity, ( "Invalid reply code " & Image (Client.Pointer) & " not in 200..554" ) ); end if; Client.Code := (False, Reply_Code (Client.Pointer)); Pointer := Pointer + 1; Client.Receive_State := Receive_Class; Client.End_Of_Reply := True; Client.Pointer := 1; exit; when Character'Pos ('-') => if Client.Count = 0 then Raise_Exception ( Data_Error'Identity, "Missing continuation reply code " ); elsif Client.Pointer not in 200..554 then Raise_Exception ( Data_Error'Identity, ( "Invalid continuation reply code " & Image (Client.Pointer) & " not in 200..554" ) ); end if; Client.Code := (False, Reply_Code (Client.Pointer)); Pointer := Pointer + 1; Client.Receive_State := Receive_Line; Client.End_Of_Reply := False; Client.Pointer := 1; exit; when others => Raise_Exception ( Data_Error'Identity, "Invalid reply code, not numerical" ); end case; exit when Pointer > Data'Last; end loop; when Receive_Class => if ( Pointer = Data'Last or else Data (Pointer + 1) /= Character'Pos ('.') ) then -- Assume plain code Client.Receive_State := Receive_Line; else case Data (Pointer) is when Character'Pos ('0') | Character'Pos ('1') | Character'Pos ('3') | Character'Pos ('6')..Character'Pos ('9') => Raise_Exception ( Data_Error'Identity, ( "Invalid extended status code class, " & "not 2,4,5" ) ); when Character'Pos ('2') => Client.Receive_State := Receive_Subject; Client.Count := 0; Pointer := Pointer + 1; Client.Code := (True, Client.Code.Reply, (Success, 0, 0)); when Character'Pos ('4') => Client.Receive_State := Receive_Subject; Client.Count := 0; Pointer := Pointer + 1; Client.Code := ( True, Client.Code.Reply, (Persistent_Transient_Failure, 0, 0) ); when Character'Pos ('5') => Client.Receive_State := Receive_Subject; Client.Count := 0; Pointer := Pointer + 1; Client.Code := ( True, Client.Code.Reply, (Permanent_Failure, 0, 0) ); when others => Client.Receive_State := Receive_Line; end case; end if; when Receive_Subject => case Data (Pointer) is when Character'Pos ('.') => if Client.Count = 0 then Client.Count := 1; Client.Code.Error.Subject := 0; elsif Client.Count = 1 then Raise_Exception ( Data_Error'Identity, ( "Invalid extended status code, " & "missing numeric code subject" ) ); else Client.Receive_State := Receive_Detail; Client.Count := 0; Client.Code.Error.Detail := 0; end if; when Character'Pos ('0')..Character'Pos ('9') => if Client.Count = 0 then Raise_Exception ( Data_Error'Identity, ( "Invalid extended status code, " & "missing (.) after the code class" ) ); elsif Client.Count > 3 then Raise_Exception ( Data_Error'Identity, ( "Invalid extended status code, " & "subject is longer than 3 digits" ) ); end if; Client.Count := Client.Count + 1; Client.Code.Error.Subject := ( Client.Code.Error.Subject * 10 + Code_Subject ( Data (Pointer) - Character'Pos ('0') ) ); when others => Raise_Exception ( Data_Error'Identity, ( "Invalid extended status code subject, " & "not numeric ended by a dot (.)" ) ); end case; Pointer := Pointer + 1; when Receive_Detail => case Data (Pointer) is when Character'Pos ('0')..Character'Pos ('9') => if Client.Count > 3 then Raise_Exception ( Data_Error'Identity, ( "Invalid extended status code, " & "detail is longer than 3 digits" ) ); end if; Client.Count := Client.Count + 1; Client.Code.Error.Detail := ( Client.Code.Error.Detail * 10 + Code_Detail ( Data (Pointer) - Character'Pos ('0') ) ); Pointer := Pointer + 1; when Character'Pos (' ') => if Client.Count = 0 then Raise_Exception ( Data_Error'Identity, ( "Invalid extended status code, " & "missing numeric code detail" ) ); end if; Pointer := Pointer + 1; Client.Receive_State := Receive_Line; when others => if Client.Count = 0 then Raise_Exception ( Data_Error'Identity, ( "Invalid extended status code, " & "missing numeric code detail" ) ); end if; Client.Receive_State := Receive_Line; end case; when Receive_Line => loop if Data (Pointer) = Stream_Element'Val (13) then Client.Receive_State := Receive_LF; Pointer := Pointer + 1; exit; elsif Client.Pointer > Client.Reply'Last then Raise_Exception ( Data_Error'Identity, ( "The reply line is longer than " & Image (Client.Reply_Length) & " characters" ) ); end if; Client.Reply (Client.Pointer) := Character'Val (Data (Pointer)); Client.Pointer := Client.Pointer + 1; Pointer := Pointer + 1; exit when Pointer > Data'Last; end loop; when Receive_LF => if Data (Pointer) /= Stream_Element'Val (10) then Raise_Exception ( Data_Error'Identity, ( "Response terminating is expected " & "after " ) ); end if; Pointer := Pointer + 1; Client.Receive_State := Receive_Code; Client.Count := 0; if Client.Code.Reply >= 400 then -- Fatal error On_Reply_Error (Client); elsif not Client.End_Of_Reply then -- Multiline response case Client.Command is when SMTP_DATA | SMTP_HELP | SMTP_MAIL | SMTP_NOOP | SMTP_RCPT | SMTP_RSET | SMTP_Sent | SMTP_QUIT | SMTP_AUTH | SMTP_STARTTLS | SMTP_Greeting => null; when SMTP_HELO | SMTP_EHLO => On_EHLO_Response ( Client, Client.Reply (1..Client.Pointer - 1) ); end case; else case Client.Command is when SMTP_Greeting => On_Greeting ( Client, Client.Code, Client.Reply (1..Client.Pointer - 1) ); when SMTP_Sent => Client.Queue.Status := Mail_Sent; Send_Success ( SMTP_Client'Class (Client), (Reference => Ref (Client.Queue)) ); Delete (Client.Queue); On_Mail (Client); when SMTP_HELO => On_Mail (Client); when SMTP_EHLO => On_Mail (Client); when SMTP_AUTH => On_Auth (Client); when SMTP_MAIL => Client.Command := SMTP_RCPT; Client.Header := Mail_To; Client.Index := 0; On_Recipient (Client); when SMTP_RCPT => On_Recipient (Client); when SMTP_STARTTLS => Create_Transport (Client); Client.Command := SMTP_EHLO; Client.Count := 0; return; when SMTP_DATA => Client.Send_State := Send_Header; Client.Header := Mail_Header'First; Client.Index := 1; Sent (Client); when SMTP_RSET => null; when SMTP_HELP => null; when SMTP_NOOP => null; when SMTP_QUIT => Raise_Exception ( Connection_Error'Identity, "End of SMPT connection" ); end case; end if; end case; end loop; exception when Connection_Error => Shutdown (Client); raise; when Data_Error => raise; when Error : others => Raise_Exception ( Data_Error'Identity, Exception_Message (Error) ); end Received; procedure Remove ( List : in out Mail_Address_List; Address : String ) is use Persistent.Catalogue; begin Remove (List.Set, Trim (Address)); end Remove; procedure Remove ( List : in out Mail_Address_List; Index : Positive ) is use Persistent.Catalogue; begin Remove (List.Set, Index); end Remove; procedure Send ( Client : in out SMTP_Client; Message : Mail ) is begin Check (Message); declare This : constant Mail_Object_Ptr := Ptr (Message.Reference); begin This.Status := Mail_Pending; if Client.Queue = null then -- Empty messages queue Client.Queue := This; This.Next := This; This.Previous := This; else -- Add to the queue tail This.Next := Client.Queue; This.Previous := Client.Queue.Previous; Client.Queue.Previous.Next := This; Client.Queue.Previous := This; end if; Increment_Count (This.all); end; end Send; procedure Send ( Client : in out SMTP_Client; Messages : Mail_Array ) is begin for Index in Messages'Range loop Check (Messages (Index)); end loop; for Index in Messages'Range loop declare This : constant Mail_Object_Ptr := Ptr (Messages (Index).Reference); begin This.Status := Mail_Pending; if Client.Queue = null then -- Empty messages queue Client.Queue := This; This.Next := This; This.Previous := This; else -- Add to the queue tail This.Next := Client.Queue; This.Previous := Client.Queue.Previous; Client.Queue.Previous.Next := This; Client.Queue.Previous := This; end if; Increment_Count (This.all); end; end loop; end Send; procedure Send_Abandoned ( Client : in out SMTP_Client; Messages : Mail_Array ) is begin for Index in Messages'Range loop Trace ( Client.Listener.Factory.all, ( "Abandoning sending the mail " & Quote (Get (Messages (Index), Mail_Subject)) & " to: " & Image (Get (Messages (Index), Mail_To)) ) ); end loop; end Send_Abandoned; procedure Send_Data ( Client : in out SMTP_Client'Class; Data : Stream_Element_Array ) is Pointer : Stream_Element_Offset := Data'First; begin Send (Client, Data, Pointer); if Pointer < Data'Last then Raise_Exception ( Data_Error'Identity, ( "The output buffer is too small. At least " & Image (Integer (Data'Last - Pointer)) & " more elements required" ) ); end if; end Send_Data; procedure Send_Error ( Client : in out SMTP_Client; Code : Error_Code; Context : SMTP_Command; Reply : String ) is begin Trace ( Client.Listener.Factory.all, "Error: " & Image (Code) & ". " & Reply ); end Send_Error; procedure Send_Error ( Client : in out SMTP_Client; Code : Error_Code; Context : SMTP_Command; Reply : String; Message : Mail ) is begin Trace ( Client.Listener.Factory.all, ( "Error: " & Image (Code) & ". " & Reply & ". While sending mail " & Quote (Get (Message, Mail_Subject)) & " to: " & Image (Get (Message, Mail_To)) ) ); end Send_Error; procedure Send_Success ( Client : in out SMTP_Client; Message : Mail ) is begin Trace ( Client.Listener.Factory.all, ( "Mail " & Quote (Get (Message, Mail_Subject)) & " successfully sent to: " & Image (Get (Message, Mail_To)) ) ); end Send_Success; procedure Send_Text ( Client : in out SMTP_Client'Class; Text : String ) is Pointer : Integer := Text'First; begin Send (Client, Text, Pointer); if Pointer < Text'Last then Raise_Exception ( Data_Error'Identity, ( "The output buffer is too small. At least " & Image (Text'Last - Pointer) & " more elements required" ) ); end if; end Send_Text; procedure Sent (Client : in out SMTP_Client) is begin loop case Client.Send_State is when Send_Boundary_First => Send (Client, Boundary (3..Boundary'Last), Client.Index); if Client.Index <= Boundary'Last then return; end if; declare Message : Mail_Object'Class renames Client.Queue.all; begin if Message.Contents /= null then Client.Send_State := Send_String_Body; elsif Message.First /= null then if Client.Encoded = null then Client.Encoded := new String (1..Encoded_Length + 3); end if; Client.Send_State := Send_Content_Header; else Client.Send_State := Send_Boundary_Last; end if; Client.Index := 1; end; when Send_Boundary_Middle => Send (Client, Boundary (1..2 + 2 + 16 + 2), Client.Index); if Client.Index <= 2 + 2 + 16 + 2 then return; end if; Client.Send_State := Send_Content_Header; Client.Index := Client.Attachment.Header'First; when Send_Boundary_Last => Send ( Client, Boundary (2 + 2..2 + 2 + 16), Client.Index ); if Client.Index <= 2 + 2 + 16 then return; end if; Client.Send_State := Send_Multipart_End; Client.Index := Multipart_End'First; when Send_Content_Header => Send ( Client, Client.Attachment.Header, Client.Index ); if Client.Index <= Client.Attachment.Header'Last then return; end if; Client.Send_State := Send_Content; Client.Index := 1; Client.Encoded_Last := 0; if Client.Encoded = null then Client.Encoded := new String (1..Encoded_Length + 3); end if; when Send_Colon => Send (Client, Colon, Client.Index); if Client.Index <= Colon'Last then return; end if; Client.Send_State := Send_Value; Client.Index := 1; when Send_Command => return; when Send_Content => loop if Client.Index > Client.Encoded_Last then declare -- Get a next chunk of encoded data Buffer : Stream_Element_Array (1..Chunk_Length); Last : Stream_Element_Offset; begin Read (Client.Attachment.all, Buffer, Last); if Last < Buffer'First then -- No more data Close (Client.Attachment.all); Client.Attachment := Client.Attachment.Next; if Client.Attachment = null then Client.Send_State := Send_Boundary_Last; else Client.Send_State := Send_Boundary_Middle; end if; Client.Index := 1; exit; end if; Client.Encoded_Last := Client.Encoded'First; Put ( Client.Encoded.all, Client.Encoded_Last, To_Base64 (To_String (Buffer (1..Last))) ); Put ( Client.Encoded.all, Client.Encoded_Last, CRLF ); Client.Encoded_Last := Client.Encoded_Last - 1; Client.Index := Client.Encoded'First; end; end if; Send ( Client, Client.Encoded (Client.Index..Client.Encoded_Last), Client.Index ); if Client.Index <= Client.Encoded_Last then return; end if; end loop; when Send_Header => declare Message : Mail_Object'Class renames Client.Queue.all; begin case Client.Header is when Text_Header => if Message.Texts (Client.Header) = null then Client.Header := Mail_Header'Val ( Mail_Header'Pos (Client.Header) + 1 ); else declare Text : constant String := Image (Client.Header); begin Send (Client, Text, Client.Index); if Client.Index <= Text'Last then return; end if; Client.Send_State := Send_Colon; Client.Index := 1; end; end if; when List_Header => if Is_Empty ( Message.Addresses (Client.Header) ) then Client.Header := Mail_Header'Val ( Mail_Header'Pos (Client.Header) + 1 ); else declare Text : constant String := Image (Client.Header); begin Send (Client, Text, Client.Index); if Client.Index <= Text'Last then return; end if; Client.Send_State := Send_Colon; Client.Index := 1; end; end if; when Mail_Date => declare Text : constant String := Image (Client.Header); begin Send (Client, Text, Client.Index); if Client.Index <= Text'Last then return; end if; Client.Send_State := Send_Colon; Client.Index := 1; end; when Mail_Body => declare Message : Mail_Object'Class renames Client.Queue.all; begin if Message.First = null then -- Single part Client.Send_State := Send_CRLF; Client.Index := 1; else -- Multiple parts Client.Attachment := Message.First; Client.Send_State := Send_Boundary_First; Client.Index := 1; end if; end; end case; end; when Send_Value => declare Message : Mail_Object'Class renames Client.Queue.all; begin case Client.Header is when Text_Header => declare Text : constant String := Get (Message, Client.Header); begin Send (Client, Text, Client.Index); if Client.Index <= Text'Last then return; end if; Client.Send_State := Send_CRLF; Client.Index := 1; end; when List_Header => declare Text : constant String := Image ( Message.Addresses (Client.Header) ); begin Send (Client, Text, Client.Index); if Client.Index <= Text'Last then return; end if; Client.Send_State := Send_CRLF; Client.Index := 1; end; when Mail_Date => declare Text : constant String := To_String ( Message.Dates (Client.Header) ); begin Send (Client, Text, Client.Index); if Client.Index <= Text'Last then return; end if; Client.Send_State := Send_CRLF; Client.Index := 1; end; when Mail_Body => Send (Client, CRLF, Client.Index); if Client.Index <= CRLF'Last then return; end if; end case; end; when Send_CRLF => Send (Client, CRLF, Client.Index); if Client.Index <= CRLF'Last then return; elsif Client.Header = Mail_Body then declare Message : Mail_Object'Class renames Client.Queue.all; begin if Message.Contents /= null then Client.Send_State := Send_String_Body; elsif Message.First /= null then Client.Send_State := Send_Boundary_First; else Client.Send_State := Send_Data_End; end if; Client.Index := 1; end; else Client.Header := Mail_Header'Val ( Mail_Header'Pos (Client.Header) + 1 ); Client.Send_State := Send_Header; Client.Index := 1; end if; when Send_Data_End => Send (Client, Data_End, Client.Index); if Client.Index <= Data_End'Last then return; end if; Client.Receive_State := Receive_Code; Client.Send_State := Send_Command; Client.Command := SMTP_Sent; Client.Index := 1; Client.Count := 0; when Send_Multipart_End => Send (Client, Multipart_End, Client.Index); if Client.Index <= Multipart_End'Last then return; end if; Client.Receive_State := Receive_Code; Client.Send_State := Send_Command; Client.Command := SMTP_Sent; Client.Index := 1; Client.Count := 0; when Send_String_Dot => declare Pointer : Integer := Dot'First; begin Send (Client, Dot, Pointer); if Pointer <= Dot'Last then return; end if; Client.Send_State := Send_String_Body; end; when Send_String_Body => declare Message : Mail_Object'Class renames Client.Queue.all; Index : Integer; begin loop if Client.Index > Message.Contents'Last then On_Content_End (Client, Message); exit; end if; Index := Client.Index; while Index <= Message.Contents'Last loop case Message.Contents (Index) is when '.' => if Index = Message.Contents'First then Index := Index + 1; Client.Send_State := Send_String_Dot; exit; end if; Index := Index + 1; when CR => Index := Index + 1; if Is_Prefix ( LF_Dot, Message.Contents.all, Index ) then Index := Index + 2; Client.Send_State := Send_String_Dot; exit; end if; when others => Index := Index + 1; end case; end loop; Send ( Client, Message.Contents (Client.Index..Index - 1), Client.Index ); if Client.Index < Index then Client.Send_State := Send_String_Body; return; elsif Client.Send_State = Send_String_Dot then exit; end if; end loop; end; end case; end loop; end Sent; procedure Set (Data : in out String_Ptr; Value : String) is begin if Data /= null then if Data.all = Value then return; end if; Free (Data); end if; Data := new String'(Value); end Set; procedure Set ( Object : in out Mail_Object; Header : Text_Header; Text : String ) is begin Set (Object.Texts (Header), Text); end Set; procedure Set ( Message : in out Mail; Header : Text_Header; Text : String ) is begin if not Is_Valid (Message.Reference) then Set (Message.Reference, new Mail_Object); end if; Set (Ptr (Message.Reference).all, Header, Text); end Set; procedure Set ( Message : in out Mail; Header : List_Header; List : Mail_Address_List'Class ) is use Persistent.Catalogue; begin if not Is_Valid (Message.Reference) then Set (Message.Reference, new Mail_Object); end if; Ptr (Message.Reference).Addresses (Header).Set := List.Set; end Set; procedure Set ( Message : in out Mail; Header : Date_Header; Date : Time ) is begin if not Is_Valid (Message.Reference) then Set (Message.Reference, new Mail_Object); end if; Ptr (Message.Reference).Dates (Header) := Date; end Set; procedure Set_Enhanced ( Client : in out SMTP_Client; Enhanced : Boolean ) is begin Client.Force_ESMTP := Enhanced; end Set_Enhanced; procedure Set_MIME (Object : in out Mail_Object'Class) is begin Set (Object, Mail_MIME_Version, "1.0"); Set ( Object, Mail_Content_Type, "multipart/mixed; boundary=""" & Boundary (7..16 + 4) & """" ); if Object.Contents /= null then Prepend ( Object, Create_String_Attachment (Object.Contents.all) ); Free (Object.Contents); end if; end Set_MIME; procedure Set_Credentials ( Client : in out SMTP_Client; User : String; Password : String; Accepted : SMTP_AUTH_Mechanism := SMTP_AUTH_Mechanism'Last ) is begin Set (Client.User, User); Set (Client.Password, Password); Client.Supported := Accepted; end Set_Credentials; procedure Set_TLS ( Client : in out SMTP_Client; Enable : Boolean; Always : Boolean := False ) is begin Client.Accept_TLS := Enable; Client.Force_TLS := Always; end Set_TLS; function Value (Text : String_Ptr) return String is begin if Text = null then return ""; else return Text.all; end if; end Value; function "/" (Left, Right : String) return Mail_Address_List is use Persistent.Catalogue; Result : Mail_Address_List; begin Add_Address (Result, Left); Add_Address (Result, Right); return Result; end "/"; function "/" ( List : Mail_Address_List; Address : String ) return Mail_Address_List is use Persistent.Catalogue; Result : Mail_Address_List := List; begin Add_Address (Result, Address); return Result; end "/"; function "and" (Left, Right : Mail_Address_List) return Mail_Address_List is use Persistent.Catalogue; begin return (Set => Left.Set and Right.Set); end "and"; function "or" (Left, Right : Mail_Address_List) return Mail_Address_List is use Persistent.Catalogue; begin return (Set => Left.Set or Right.Set); end "or"; function "xor" (Left, Right : Mail_Address_List) return Mail_Address_List is use Persistent.Catalogue; begin return (Set => Left.Set xor Right.Set); end "xor"; begin Add (Extensions, "8BITMIME", SMTP_8BITMIME); Add (Extensions, "ATRN", SMTP_ATRN); Add (Extensions, "AUTH", SMTP_AUTH); Add (Extensions, "AUTH=", SMTP_AUTH); Add (Extensions, "BINARYMIME", SMTP_BINARYMIME); Add (Extensions, "CHECKPOINT", SMTP_CHECKPOINT); Add (Extensions, "CHUNKING", SMTP_CHUNKING); Add (Extensions, "DSN", SMTP_DSN); Add (Extensions, "ENHANCEDSTATUSCODES", SMTP_ENHANCEDSTATUSCODES); Add (Extensions, "ETRN", SMTP_ETRN); Add (Extensions, "EXPN", SMTP_EXPN); Add (Extensions, "HELP", SMTP_HELP); Add (Extensions, "ONEX", SMTP_ONEX); Add (Extensions, "PIPELINING", SMTP_PIPELINING); Add (Extensions, "RSET", SMTP_RSET); Add (Extensions, "SAML", SMTP_SAML); Add (Extensions, "SEND", SMTP_SEND); Add (Extensions, "SIZE", SMTP_SIZE); Add (Extensions, "SMTPUTF8", SMTP_SMTPUTF8); Add (Extensions, "SOML", SMTP_SOML); Add (Extensions, "STARTTLS", SMTP_STARTTLS); Add (Extensions, "TIME", SMTP_TIME); Add (Extensions, "TLS", SMTP_TLS); Add (Extensions, "TURN", SMTP_TURN); Add (Extensions, "UTF8SMTP", SMTP_UTF8SMTP); Add (Extensions, "VERB", SMTP_VERB); Add (Extensions, "VRFY", SMTP_VRFY); Add (Extensions, "X-EXPS", SMTP_X_EXPS); Add (Extensions, "X-EXPS=LOGIN", SMTP_X_EXPS_LOGIN); Add (Extensions, "X-LINK2STATE", SMTP_X_LINK2STATE); Add (Extensions, "X-RCPTLIMIT", SMTP_X_RCPTLIMIT); Add (Extensions, "X-TURNME", SMTP_X_TURNME); Add (Extensions, "XADR", SMTP_XADR); Add (Extensions, "XAUD", SMTP_XAUD); Add (Extensions, "XDSN", SMTP_XDSN); Add (Extensions, "XEXCH50", SMTP_XEXCH50); Add (Extensions, "XGEN", SMTP_XGEN); Add (Extensions, "XONE", SMTP_XONE); Add (Extensions, "XQUE", SMTP_XQUE); Add (Extensions, "XREMOTEQUEUE", SMTP_XREMOTEQUEUE); Add (Extensions, "XSTA", SMTP_XSTA); Add (Extensions, "XTRN", SMTP_XTRN); Add (Extensions, "XUSR", SMTP_XUSR); Add (Extensions, "XVRB", SMTP_XVRB); Add (Authentications, "ANONYMOUS", SMTP_ANONYMOUS); Add (Authentications, "CRAM-MD5", SMTP_CRAM_MD5); Add (Authentications, "DIGEST-MD5", SMTP_DIGEST_MD5); Add (Authentications, "LOGIN", SMTP_LOGIN); Add (Authentications, "PLAIN", SMTP_PLAIN); Add (Challenges, "algorithm", SMTP_ALGORITHM); Add (Challenges, "charset", SMTP_CHARSET); Add (Challenges, "cnonce", SMTP_CNONCE); Add (Challenges, "digest-uri", SMTP_DIGEST_URI); Add (Challenges, "nonce", SMTP_NONCE); Add (Challenges, "qop", SMTP_QOP); Add (Challenges, "realm", SMTP_REALM); end GNAT.Sockets.SMTP.Client;