------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2006-2021, AdaCore -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, 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 MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package and its children provide routines to manipulate mailboxes and -- email messages with Ada.Calendar; with Ada.Containers.Doubly_Linked_Lists; with Ada.Finalization; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with GNATCOLL.VFS; package GNATCOLL.Email is ---------------------- -- Charset sections -- ---------------------- type Charset_String is record Contents : Unbounded_String; Charset : Unbounded_String; end record; Null_Charset_String : constant Charset_String; -- This type represents a string and its charset. Contents must be -- interpreted relatively to Charset, i.e. characters above 127 must be -- read from that charset. For instance character 161 is an inverted -- exclamation mark in iso-8859-1, but a latin letter A with ogonek in -- iso-8859-2. package Charset_String_List is new Ada.Containers.Doubly_Linked_Lists (Charset_String); -- Single-byte charsets Charset_US_ASCII : constant String := "us-ascii"; Charset_ISO_8859_1 : constant String := "iso-8859-1"; Charset_ISO_8859_2 : constant String := "iso-8859-2"; Charset_ISO_8859_3 : constant String := "iso-8859-3"; Charset_ISO_8859_4 : constant String := "iso-8859-4"; Charset_ISO_8859_9 : constant String := "iso-8859-9"; Charset_ISO_8859_10 : constant String := "iso-8859-10"; Charset_ISO_8859_13 : constant String := "iso-8859-13"; Charset_ISO_8859_14 : constant String := "iso-8859-14"; Charset_ISO_8859_15 : constant String := "iso-8859-15"; Charset_Windows_1252 : constant String := "windows-1252"; -- Multi-byte charsets Charset_UTF_8 : constant String := "utf-8"; Charset_Shift_JIS : constant String := "shift-jis"; Charset_EUC : constant String := "x-euc"; --------------- -- Addresses -- --------------- type Email_Address is record Real_Name : Unbounded_String; Address : Unbounded_String; end record; Null_Address : constant Email_Address; overriding function "=" (Addr1, Addr2 : Email_Address) return Boolean; -- Whether Addr1 and Addr2 have the same address, even if real name differs ------------- -- Headers -- ------------- type Header is tagged private; Null_Header : constant Header; Default_Max_Header_Line_Length : constant := 76; -- Default maximal length that headers should use Content_Description : constant String := "Content-Description"; Content_Disposition : constant String := "Content-Disposition"; Content_Transfer_Encoding : constant String := "Content-Transfer-Encoding"; Content_Type : constant String := "Content-Type"; MIME_Version : constant String := "MIME-Version"; Message_ID : constant String := "Message-ID"; CC : constant String := "CC"; -- The standard MIME headers for mail messages. -- For Content_Disposition, see RFC 2183 at -- http://www.faqs.org/rfcs/rfc2183.html Text_Plain : constant String := "text/plain"; Text_Html : constant String := "text/html"; Application_Octet_Stream : constant String := "application/octet-stream"; Application_Json : constant String := "application/json"; Message_RFC822 : constant String := "message/rfc822"; Multipart_Mixed : constant String := "multipart/mixed"; Multipart_Alternative : constant String := "multipart/alternative"; Multipart_Signed : constant String := "multipart/signed"; Multipart_Digest : constant String := "multipart/digest"; Image_Jpeg : constant String := "image/jpeg"; Image_Gif : constant String := "image/gif"; Text_Xvcard : constant String := "text/x-vcard"; -- Some of the standard MIME types function Create (Name : String; Value : String; Charset : String := Charset_US_ASCII) return Header; function Create (Name : String; Value : Charset_String_List.List) return Header; -- Create a new header, with an unparsed string Value. The interpretation -- of Value depends on the specific header (it could be a date, some -- content type,...). -- Charset indicates the charset used for Value. If Value already contains -- a Mime-encoded string (such as '=?iso-8859-1?q?p=F4stal?='), the -- charset should be left to us-ascii. If Value contains extended -- characters from another charset, the latter must be specified. For -- instance, you could replace the previous mime-encoded string with: -- Value='pôstal' Charset='iso-8859-1' -- The charset influences how the header is encoded when it is displayed in -- a message. -- The Value, if it was split into several lines, must have been normalized -- and the newline characters removed. procedure Append (H : in out Header'Class; Value : String; Charset : String := Charset_US_ASCII); procedure Append (H : in out Header'Class; Value : Charset_String_List.List); -- Appends some content to the header's value procedure Set_Param (H : in out Header'Class; Param_Name : String; Param_Value : String); -- Set the value for one of H's parameters. Such parameters are typically -- used for the Content-Type header, to store the file name, or the -- boundary for instance. They appear as: -- Content-Type: text/plain; charset="iso-8859-1" -- If such a parameter is already set, it is replaced in-place, i.e. the -- order of parameters is preserved. function Get_Param (H : Header'Class; Param_Name : String) return String; -- Get the value for one of H's parameters, or "" if there is no such -- param. -- This automatically handles continuation headers, i.e. cases where the -- value of the parameter was split onto several lines, as in: -- filename*0="value1"; -- filename*1="value2" procedure Delete_Param (H : in out Header'Class; Param_Name : String); -- Remove in place one of H's parameters. -- No error is the parameter doesn't exist function Get_Name (H : Header'Class) return String; -- Return the name of the header, lower cased function Get_Value (H : Header'Class) return Charset_String_List.List; -- Return the value of the header procedure To_String (H : Header'Class; Max_Line_Len : Positive := Default_Max_Header_Line_Length; Show_Header_Name : Boolean := True; Result : out Unbounded_String); function To_String (H : Header'Class; Max_Line_Len : Positive := Default_Max_Header_Line_Length; Show_Header_Name : Boolean := True) return String; -- Return the header's value as string. Optionally, the header's name can -- be prepended. -- Lines will be split as needed to match Max_Line_Len. The first line will -- be shorted to take into account the header's name. -- The header is MIME encoded if necessary so that it only contains ASCII -- characters suitable for sending in an email message. function To_Time (H : Header'Class) return Ada.Calendar.Time; -- Interprets the header's value as a time, and returns it. This mostly -- applies to the 'Date:' header. The returned time is UTC. -- The format of the header must match the date format described in -- RFC 2822. When the format is incorrect, No_Time is returned. -------------- -- Messages -- -------------- type Message is tagged private; Null_Message : constant Message; function New_Message (MIME_Type : String := Text_Plain; Charset : String := Charset_US_ASCII) return Message; -- Return a new empty message. The memory will be freed automatically when -- the message is no longer used. -- The MIME type is the initial type, but it can be changed at any time by -- changing the header. The mail will be created as multi-part if -- MIME_Type is one of the standard multipart/* types. Otherwise, a single -- part message is created, but that will change automatically depending on -- the payload you set for the message. If MIME_Type is the empty string, -- no Content-Type header is set. function Clone_Message (Msg : Message) return Message; -- Return a copy of the given message. -- ??? In the case of a multipart message, the contents of each -- part of the message is not duplicated. In other words, modifying -- the contents of any part of the payload will affect both the -- copy and the original. function Reply_To (Msg : Message'Class; From_Email : String; From_Real_Name : String := ""; Quote : Boolean := True; Reply_All : Boolean := True; Reply_Filter : access function (Recipient : Email_Address) return Boolean := null; Local_Date : Ada.Calendar.Time := Ada.Calendar.Clock; Charset : String := Charset_US_ASCII) return Message; -- Create a new message as a reply to Msg. This impacts subjects, -- recipients,... If Quote is True, then Msg is quoted in the payload of -- the new message. -- Headers are set so that the reply will appear in the same thread as Msg -- in mailers that support threads. Charset, is supplied, is used for -- encoding of From_Real_Name. If Reply_All is True, all recipients of -- the original message are added to the Cc: header of the reply. If -- in addition Reply_Filter is not null, then only recipients for which -- Reply_Filter returns True are added. procedure Set_Default_Headers (Msg : in out Message'Class; From_Email : String; Subject : String := "No Subject"; From_Real_Name : String := ""; Local_Date : Ada.Calendar.Time := Ada.Calendar.Clock; Charset : String := Charset_US_ASCII); -- Set the standard headers for the message. This is just a convenient -- subprogram, since the same can be done by manipulating directly the -- headers. Charset is used for MIME encoding of the From: and Subject: -- headers only. procedure Set_From_Header (Msg : in out Message'Class; From_Email : String; From_Real_Name : String; Charset : String); -- Create and set a From: header for Msg using the given email address and -- real name. The real name has the indicated Charset. type Header_Filter is access function (H : Header'Class) return Boolean; -- A filter for headers. It is returned True, the header will be displayed, -- otherwise it is skipped. type Payload_Filter is access function (Attachment : Message'Class) return Boolean; -- Whether a given payload part should be displayed when a message is -- converted to a string. If it returns True, that part is displayed. -- When the filter is unspecified to To_String, all payloads are output. -- This filter only applies in the case of multipart messages, and only to -- the toplevel attachments (i.e. if an attachment is itself a message with -- other attachments, the filter will not be applied for these). procedure To_String (Msg : Message'Class; Envelope : Boolean := False; Header_Max_Line_Len : Positive := Default_Max_Header_Line_Length; Subject_Max_Line_Len : Positive := Default_Max_Header_Line_Length; Content_Filter : Payload_Filter := null; Filter : Header_Filter := null; Decode : Boolean := False; Quote_From : Boolean := False; Result : out Unbounded_String); -- Return the message as string. This string is suitable for passing to any -- program like sendmail to forward the mail to its recipients. -- If Envelope is True, the envelope line, if known, is included. -- If Content_Filter is specified, it can be used to filter out which part -- of multipart message should be displayed. -- If Filter is specified, it can be used to filter out which headers -- should be displayed. -- If Decode is True and this message is MIME-encoded, it is automatically -- decoded. -- If Quote_From is true, then each line of Msg's payload preceded by a -- blank line and starting with "From " will be prepended with ">" in order -- to avoid further tools to be confused with the From_ message delimiter. -- -- The message might be modified if for instance a boundary needs to be -- created or adjusted for a multipart message. procedure Set_Envelope_From (Msg : in out Message'Class; From : String); procedure Set_Envelope_From (Msg : in out Message'Class; Email : String; Local_Date : Ada.Calendar.Time); function Get_Envelope_From (Msg : Message'Class) return String; -- Set the "From " line used for the envelope of the message function Date_From_Envelope (Msg : Message'Class) return Ada.Calendar.Time; -- Return the date read in the envelope of the message. It is recommended -- that you get the date from the 'Date:' header when available instead. function Sender_From_Envelope (Msg : Message'Class) return String; -- Return the sender part of the envelope. It is recommended that you use -- the From: header instead when available procedure Add_Header (Msg : in out Message'Class; H : Header'Class); -- Set the unparsed block of headers for the message. -- If there is already a header with the same name, it isn't overridden. -- Instead, two headers with the same name will exist for the message. procedure Delete_Headers (Msg : Message'Class; Name : String); procedure Delete_Header (Msg : Message'Class; H : Header'Class); -- Delete either all headers with the given name (all if Name is the empty -- string), or a specific header. procedure Replace_Header (Msg : Message'Class; H : Header'Class); -- Replace the first header with the same name by H, and delete all other -- headers with the same name. This is different from doing a -- Delete_Headers (Msg, Name); -- Add_Header (Create (Name, ...)); -- since Replace_Header will preserve the order of headers. -- If no header with the same name is found, H is simply added to the list. function Get_Header (Msg : Message'Class; Name : String) return Header; -- Return the first header of Msg with the given name. If this header -- occurs multiple times, only the first occurrence is returned. -- Name is case-insensitive function Get_Type (H : Header) return String; -- For a header H that is a Content-Type or Content-Disposition, return -- the content type or the disposition type (i.e. the initial part of the -- header, before the semicolon). The returned value is always converted -- to lower case. For a null header, an empty string is returned. function Get_Content_Type (Msg : Message'Class) return String; -- Return the MIME content type for the message. -- As per RFC 2045, there is always such a content type, even if it wasn't -- specified explicitly by the headers. It defaults to text/plain when the -- message is not part of the payload of a multipart/report message, to -- message/rfc822 otherwise. The returned value is always converted to -- lower case. function Get_Message_Id (Msg : Message) return String; -- Return the Message_Id for this message. This returns the empty string if -- no such Id is defined. Otherwise, this extracts the Id from that header, -- properly keeping only the Id itself, and not the surrounding <..> if -- they exist. function Get_Date (Msg : Message) return Ada.Calendar.Time; -- Return the date the message was sent. This information is taken from the -- Date: header if it exists, and if not from the envelope of the message. function Size (Msg : Message; Include_Attachments : Boolean) return Long_Integer; -- Return the size of the message and all its MIME parts. This size is not -- extremely precise (and doesn't reflect the size it would take to convert -- it to a string for instance), and for instance doesn't include the size -- of the headers. -- If Include_Attachments is False, then all but the first text/plain part -- will be ignored type Encoding_Type is (Encoding_7bit, Encoding_8bit, Encoding_Binary, Encoding_QP, Encoding_Base64); function Get_Encoding_Type (Msg : Message'Class) return Encoding_Type; -- Return the encoding used for this message. -- As per RFC 2045, there is always such an encoding, and if no header is -- specified then Encoding_7bit is assumed. type Header_Iterator is private; function Get_Headers (Msg : Message'Class; Name : String := "") return Header_Iterator; -- Iterate over all headers with the given name. If Name is unspecified, -- iterates over all headers of the message. For Null_Message, return an -- empty iterator. Looping over all headers is done as follows: -- Iter := Get_Headers (Msg); -- loop -- Next (Iter, H); -- exit when H = Null_Header; -- Header_Processing (H); -- end loop; procedure Next (Iter : in out Header_Iterator; H : out Header); -- Returns current header if exists or Null_Header otherwise. -- Move to the next header with the expected name. function Next (Iter : in out Header_Iterator; H : out Header) return Boolean; -- Returns True if the header exists and returns it in H parameter. -- Move cursor position to the next header. The loop over headers could be -- like this: -- -- Iter := Get_Headers (Msg); -- while Next (Iter, H) loop -- Do_Something_With (H); -- end loop; ------------- -- Payload -- ------------- -- A message can either be a single part message, ie it just contains text, -- possibly in various charsets or a multi part message, in which case it -- can have attached files, contain nested messages, etc. -- The content of the message, whether single or multi part, is called the -- payload. -- Since each part of a multi-part message can itself have its own headers -- and be a nested message, the actual payload of a message is represented -- as a list of messages. function Is_Multipart (Msg : Message'Class) return Boolean; -- Whether the message contains several parts, and must be encoded as a -- multipart email message. If False, the payload is a simple string. Multipart_Error : exception; -------------------------- -- Single part messages -- -------------------------- procedure Set_Text_Payload (Msg : Message'Class; Payload : Unbounded_String; MIME_Type : String := Text_Plain; Disposition : String := ""; Charset : String := Charset_US_ASCII; Prepend : Boolean := False); -- Set the payload of the message, as text. No parsing is done. -- If the message is a single part message, this is the text of the -- message. If the message is a multi-part message, this is set as one of -- the parts, with the given MIME type. As a result, it can be called -- several times in such a case, each time will create a new part. -- If MIME_Type is set to the empty string, it is not updated in the -- message. This is mostly useful when Msg was parsed through one of the -- functions in Email.Parser. -- If Disposition is specified, it is used as the value of the -- Content-Disposition header of the text part. -- When Msg is a multi-part message, the new part is either appended after -- the existing parts, or prepend before, depending on the Prepend -- parameter. If Msg is a single part message, then Payload will replace -- the current payload if Prepend is False, otherwise the old payload is -- preserved and set after the new one. procedure Set_Text_Payload (Msg : Message'Class; Payload : String; MIME_Type : String := Text_Plain; Disposition : String := ""; Charset : String := Charset_US_ASCII; Prepend : Boolean := False); -- The same like above but Payload is just a String procedure Get_Single_Part_Payload (Msg : Message'Class; Payload : out Unbounded_String; Decode : Boolean := False); -- Return the content of a message when it doesn't contain multiparts. -- If this is a multipart message, Multipart_Error is raised. -- If Decode is true and this message is MIME-encoded, it is automatically -- decoded. You can also decode it later through the subprograms in -- email-utils.ads ------------------------- -- Multi part messages -- ------------------------- type Payload_Iterator is private; function Get_Payload (Msg : Message'Class) return Payload_Iterator; -- Return an iterator over the whole content of the message. -- If the message is not a multipart message, a single element will ever -- be returned, which is Msg itself. This allows for traversing both -- single parts and multiparts messages in a single piece of code. -- The following code will find all textual contents of Msg: -- Iter := Get_Payload (Msg); -- loop -- Next (Iter, Item => Attachment); -- exit when Attachment = Null_Message; -- if Get_Main_Type (Get_Content_Type (Attachment)) = "text" then -- Get_Single_Part_Payload (Attachment, ....); -- end if; -- end loop; procedure Next (Iter : in out Payload_Iterator; Item : out Message); -- Get the next part in the payload of a message. Null_Message is -- returned when there are no more parts in the message. procedure Delete_Payload (Msg : in out Message'Class; Iter : in out Payload_Iterator); -- Remove the corresponding payload from the message procedure Convert_To_Multipart (Msg : Message'Class); -- If Msg is a single part message, convert it to a multipart/mixed whose -- first part is the original payload, else do not change the MIME -- structure of Msg (but make sure that the underlying data structure is -- suitable for storage of a multipart message). procedure Convert_To_Multipart (Msg : Message'Class; MIME_Type : String; Force : Boolean := False); -- If Msg is a single part message, convert it to a multipart with the -- indicated MIME_Type, whose first part is the original payload. Also -- do so if Msg is a multipart message if it has a different MIME subtype, -- or if Force is True. Else do not change the MIME structure of Msg -- (but make sure that the underlying data structure is suitable -- for storage of a multipart message). procedure Convert_To_Single_Part (Msg : in out Message'Class; Purge : Boolean := False); -- Try to convert Msg to a single part message. This is only doable if -- there is a single textual part, or the message is already single part. -- If Msg contains a single part which is in turn a multipart Msg, it gets -- processed as well. -- All other cases will do nothing, unless Purge is set True, in which -- case all contents are lost, and the (single part) payload is reset -- to an empty text/plain part. procedure Set_Preamble (Msg : in out Message'Class; Preamble : String); -- Set the preamble of the MIME message. -- This text will be inserted before the first boundary, i.e. the first -- attached file. -- Normally, in MIME aware mailers, this preamble will not be visible. It -- will only be visible by viewing the full text of the message. -- If the message was single-part message, it is automatically converted to -- a multi-part message. procedure Set_Epilogue (Msg : in out Message'Class; Epilogue : String); -- This is similar to the preamble, but appears after the end of the -- last document. -- If the message was single-part message, it is automatically converted to -- a multi-part message procedure Add_Payload (Msg : in out Message'Class; Payload : Message; First : Boolean := False); -- Add a new part to a multipart message. Msg is first converted to -- multipart if necessary. Payload itself is stored in Msg, i.e. modifying -- Payload later on will impact Msg. This procedure cannot be used when -- attaching a real mail message, see Attach_Msg instead. -- If First is True, then add the new part at the beginning. Otherwise, -- add it at the end. procedure Attach_Msg (Msg : in out Message'Class; Attach : Message'Class; Description : String := ""); -- Attach an existing mail message to another one (for instance when -- forwarding as attachment). type Disposition_Type is (Disposition_Attachment, Disposition_Inline); procedure Attach (Msg : in out Message'Class; Path : GNATCOLL.VFS.Virtual_File; MIME_Type : String := Application_Octet_Stream; Recommended_Filename : GNATCOLL.VFS.Virtual_File := GNATCOLL.VFS.No_File; Description : String := ""; Charset : String := Charset_US_ASCII; Disposition : Disposition_Type := Disposition_Attachment; Encoding : Encoding_Type := Encoding_Base64); -- Attach a file to the payload. The file is immediately read from the -- disk, and encoded as necessary, so this might be an expensive operation -- to perform. -- Name_Error is raised if the file is not found. function Get_Boundary (Msg : Message'Class) return String; -- Return the boundary used for Msg to separate its various parts. -- The empty string is returned if this isn't a multipart message. procedure Set_Boundary (Msg : Message'Class; Boundary : String := ""); -- Set the boundary to use between parts of the message. If the empty -- string is passed, a boundary will be added if none already exists, or -- if the current one can not be used because some part of the message -- already includes it. -- The message is automatically converted to a multipart message if you -- call this message, since boundaries can not be used with single part -- messages. -- As per RFC 1521, the boundary can only use the following characters: -- 0-9 a-z A-Z '()+_,-./:=? -- In this implementation, it must include the sequence =_. This is a -- sequence that is guaranteed to never appear in quoted-printable or -- base64 encoded parts, and this implementation takes advantage of this -- to speed up the check that the boundary can be used. -- The string =_ will be appended as many times as necessary to Boundary to -- make it valid. -- In general, you do not need to call this procedure, which is called -- automatically when needed. private type Header_Record is record Name : Unbounded_String; Value : Charset_String_List.List; Ref_Count : Natural := 1; end record; type Header_Access is access Header_Record; type Header is new Ada.Finalization.Controlled with record Contents : Header_Access; end record; procedure Adjust (H : in out Header); procedure Finalize (H : in out Header); -- Headers are stored in a list, since order might be relevant sometimes, -- especially for the 'Received:' headers. package Header_List is new Ada.Containers.Doubly_Linked_Lists (Header); type Header_Iterator is record Cursor : Header_List.Cursor; Name : Unbounded_String; end record; type Message_Record; type Message_Access is access Message_Record; type Message is new Ada.Finalization.Controlled with record Contents : Message_Access; end record; -- Smart pointer to message. This provides automatic freeing of the memory, -- but allows us to have a list of messages without having access to the -- full view of a Message, which itself contains an instance of the list. procedure Adjust (Msg : in out Message); procedure Finalize (Msg : in out Message); package Message_List is new Ada.Containers.Doubly_Linked_Lists (Message); type Payload_Iterator is record Cursor : Message_List.Cursor; Msg : Message; end record; type Message_Payload (Multipart : Boolean := False) is record case Multipart is when True => Parts : Message_List.List; Preamble : Unbounded_String; Epilogue : Unbounded_String; when False => Text : Unbounded_String; end case; end record; Null_Payload : constant Message_Payload := (False, Null_Unbounded_String); Null_Multipart_Payload : constant Message_Payload := (True, Message_List.Empty_List, Null_Unbounded_String, Null_Unbounded_String); type Message_Record is record Ref_Count : Natural := 1; Envelope_From : Unbounded_String; Headers : Header_List.List; Payload : Message_Payload; Is_Nested : Boolean := False; end record; Null_Message : constant Message := (Ada.Finalization.Controlled with Contents => null); function Next_Occurrence (S : String; Char : Character; Skip_Quotes : Boolean := False) return Integer; -- Return the index of the next occurrence of Char, or a number greater -- than S'Last if we are on the last line. -- If Skip_Quotes is true, characters between a "..." will be ignored. function Is_Whitespace (Char : Character) return Boolean; pragma Inline (Is_Whitespace); -- Whether Char is a whitespace (tab or space) procedure Skip_Whitespaces (S : String; Index : in out Integer); pragma Inline (Skip_Whitespaces); -- Skip any whitespace character, including newlines, starting at Index. -- Leaves Index on the first non-whitespace character Null_Header : constant Header := (Ada.Finalization.Controlled with null); Null_Charset_String : constant Charset_String := (Null_Unbounded_String, Null_Unbounded_String); Null_Address : constant Email_Address := (Null_Unbounded_String, Null_Unbounded_String); end GNATCOLL.Email;