PageRenderTime 42ms CodeModel.GetById 14ms app.highlight 24ms RepoModel.GetById 1ms app.codeStats 0ms

/src/yolk-email-composer.adb

http://github.com/ThomasLocke/yolk
Ada | 412 lines | 288 code | 60 blank | 64 comment | 8 complexity | 5bf35217b073d8bb773fd93c1db159dc MD5 | raw file
  1-------------------------------------------------------------------------------
  2--                                                                           --
  3--                   Copyright (C) 2010-, Thomas Løcke                   --
  4--                                                                           --
  5--  This library is free software;  you can redistribute it and/or modify    --
  6--  it under terms of the  GNU General Public License  as published by the   --
  7--  Free Software  Foundation;  either version 3,  or (at your  option) any  --
  8--  later version. This library is distributed in the hope that it will be   --
  9--  useful, but WITHOUT ANY WARRANTY;  without even the implied warranty of  --
 10--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     --
 11--                                                                           --
 12--  As a special exception under Section 7 of GPL version 3, you are         --
 13--  granted additional permissions described in the GCC Runtime Library      --
 14--  Exception, version 3.1, as published by the Free Software Foundation.    --
 15--                                                                           --
 16--  You should have received a copy of the GNU General Public License and    --
 17--  a copy of the GCC Runtime Library Exception along with this program;     --
 18--  see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
 19--  <http://www.gnu.org/licenses/>.                                          --
 20--                                                                           --
 21-------------------------------------------------------------------------------
 22
 23with AWS.SMTP.Client;
 24with GNATCOLL.Email.Utils;
 25
 26package body Yolk.Email.Composer is
 27
 28   -------------------------
 29   --  Add_Custom_Header  --
 30   -------------------------
 31
 32   procedure Add_Custom_Header
 33     (ES      : in out Structure;
 34      Name    : in     String;
 35      Value   : in     String;
 36      Charset : in     Character_Set := US_ASCII)
 37   is
 38      New_Header : Header_Data;
 39   begin
 40      New_Header.Charset := Charset;
 41      New_Header.Name := U (Name);
 42      New_Header.Value := U (Value);
 43
 44      ES.Custom_Headers.Append (New_Header);
 45   end Add_Custom_Header;
 46
 47   ---------------------------
 48   --  Add_File_Attachment  --
 49   ---------------------------
 50
 51   procedure Add_File_Attachment
 52     (ES           : in out Structure;
 53      Path_To_File : in     String;
 54      Charset      : in     Character_Set := US_ASCII)
 55   is
 56      New_Attachment : Attachment_Data;
 57   begin
 58      New_Attachment.Charset        := Charset;
 59      New_Attachment.Path_To_File   := U (Path_To_File);
 60      ES.Attachment_List.Append (New_Attachment);
 61
 62      ES.Has_Attachment := True;
 63   end Add_File_Attachment;
 64
 65   ----------------
 66   --  Add_From  --
 67   ----------------
 68
 69   procedure Add_From
 70     (ES      : in out Structure;
 71      Address : in     String;
 72      Name    : in     String := "";
 73      Charset : in     Character_Set := US_ASCII)
 74   is
 75      New_From : Email_Data;
 76   begin
 77      New_From.Address  := U (Address);
 78      New_From.Charset  := Charset;
 79      New_From.Name     := U (Name);
 80      ES.From_List.Append (New_Item => New_From);
 81   end Add_From;
 82
 83   ---------------------
 84   --  Add_Recipient  --
 85   ---------------------
 86
 87   procedure Add_Recipient
 88     (ES      : in out Structure;
 89      Address : in     String;
 90      Name    : in     String := "";
 91      Kind    : in     Recipient_Kind := To;
 92      Charset : in     Character_Set := US_ASCII)
 93   is
 94      New_Recipient : Email_Data;
 95   begin
 96      New_Recipient.Address   := U (Address);
 97      New_Recipient.Charset   := Charset;
 98      New_Recipient.Name      := U (Name);
 99
100      case Kind is
101         when Bcc =>
102            ES.Bcc_List.Append (New_Item => New_Recipient);
103         when Cc =>
104            ES.Cc_List.Append (New_Item => New_Recipient);
105         when To =>
106            ES.To_List.Append (New_Item => New_Recipient);
107      end case;
108   end Add_Recipient;
109
110   --------------------
111   --  Add_Reply_To  --
112   --------------------
113
114   procedure Add_Reply_To
115     (ES      : in out Structure;
116      Address : in     String;
117      Name    : in     String := "";
118      Charset : in     Character_Set := US_ASCII)
119   is
120      New_Reply_To : Email_Data;
121   begin
122      New_Reply_To.Address := U (Address);
123      New_Reply_To.Charset := Charset;
124      New_Reply_To.Name    := U (Name);
125      ES.Reply_To_List.Append (New_Item => New_Reply_To);
126   end Add_Reply_To;
127
128   -----------------------
129   --  Add_SMTP_Server  --
130   -----------------------
131
132   procedure Add_SMTP_Server
133     (ES   : in out Structure;
134      Host : in     String;
135      Port : in     Positive := 25)
136   is
137      New_SMTP : SMTP_Server;
138   begin
139      New_SMTP.Host := U (Host);
140      New_SMTP.Port := Port;
141      ES.SMTP_List.Append (New_Item => New_SMTP);
142   end Add_SMTP_Server;
143
144   ---------------
145   --  Is_Send  --
146   ---------------
147
148   function Is_Send
149     (ES : in Structure)
150      return Boolean
151   is
152   begin
153      return ES.Email_Is_Sent;
154   end Is_Send;
155
156   ------------
157   --  Send  --
158   ------------
159
160   procedure Send
161     (ES : in out Structure)
162   is
163      US : Unbounded_String;
164   begin
165      Set_Type_Of_Email (ES => ES);
166
167      case ES.Type_Of_Email is
168         when Text =>
169            Generate_Text_Email (ES);
170         when Text_With_Attachment =>
171            Generate_Text_With_Attachment_Email (ES);
172         when Text_And_HTML =>
173            Generate_Text_And_HTML_Email (ES);
174         when Text_And_HTML_With_Attachment =>
175            Generate_Text_And_HTML_With_Attachment_Email (ES);
176      end case;
177
178      if ES.SMTP_List.Is_Empty then
179         raise No_SMTP_Host_Set;
180      end if;
181
182      GNATCOLL.Email.To_String (Msg    => ES.Composed_Message,
183                                Result => US);
184
185      Do_The_Actual_Sending :
186      declare
187         From              : AWS.SMTP.E_Mail_Data;
188         To_Count          : Natural := Natural (ES.Bcc_List.Length) +
189           Natural (ES.Cc_List.Length) + Natural (ES.To_List.Length);
190         Recipients        : AWS.SMTP.Recipients (1 .. To_Count);
191         Server            : AWS.SMTP.Receiver;
192         Server_Failure    : Boolean := False;
193         Status            : AWS.SMTP.Status;
194      begin
195         if ES.Sender.Address /= Null_Unbounded_String then
196            From := AWS.SMTP.E_Mail (Name    => "",
197                                     Address => To_String (ES.Sender.Address));
198         else
199            From := AWS.SMTP.E_Mail
200              (Name    => "",
201               Address => To_String (ES.From_List.First_Element.Address));
202         end if;
203
204         for i in ES.Bcc_List.First_Index .. ES.Bcc_List.Last_Index loop
205            Recipients (To_Count) := AWS.SMTP.E_Mail
206              (Name    => "",
207               Address => To_String (ES.Bcc_List.Element (i).Address));
208
209            To_Count := To_Count - 1;
210         end loop;
211
212         for i in ES.Cc_List.First_Index .. ES.Cc_List.Last_Index loop
213            Recipients (To_Count) := AWS.SMTP.E_Mail
214              (Name    => "",
215               Address => To_String (ES.Cc_List.Element (i).Address));
216
217            To_Count := To_Count - 1;
218         end loop;
219
220         for i in ES.To_List.First_Index .. ES.To_List.Last_Index loop
221            Recipients (To_Count) := AWS.SMTP.E_Mail
222              (Name    => "",
223               Address => To_String (ES.To_List.Element (i).Address));
224
225            To_Count := To_Count - 1;
226         end loop;
227
228         for i in ES.SMTP_List.First_Index .. ES.SMTP_List.Last_Index loop
229            Server := AWS.SMTP.Client.Initialize
230              (Server_Name => To_String (ES.SMTP_List.Element (i).Host),
231               Port        => ES.SMTP_List.Element (i).Port);
232
233            declare
234            begin
235               AWS.SMTP.Client.Send (Server => Server,
236                                     From   => From,
237                                     To     => Recipients,
238                                     Source => To_String (US),
239                                     Status => Status);
240
241            exception
242               when others =>
243                  Server_Failure := True;
244            end;
245
246            if Server_Failure then
247               --  Reset Server_Failure
248               Server_Failure := False;
249            else
250               if AWS.SMTP.Is_Ok (Status => Status) then
251                  ES.Email_Is_Sent := True;
252                  exit;
253               end if;
254            end if;
255         end loop;
256      end Do_The_Actual_Sending;
257   end Send;
258
259   ------------
260   --  Send  --
261   ------------
262
263   procedure Send
264     (ES           : in out Structure;
265      From_Address : in     String;
266      From_Name    : in     String := "";
267      To_Address   : in     String;
268      To_Name      : in     String := "";
269      Subject      : in     String;
270      Text_Part    : in     String;
271      SMTP_Server  : in     String := "localhost";
272      SMTP_Port    : in     Positive := 25;
273      Charset      : in     Character_Set := US_ASCII)
274   is
275   begin
276      Add_From (ES      => ES,
277                Address => From_Address,
278                Name    => From_Name,
279                Charset => Charset);
280
281      Add_Recipient (ES      => ES,
282                     Address => To_Address,
283                     Name    => To_Name,
284                     Kind    => To,
285                     Charset => Charset);
286
287      Set_Subject (ES      => ES,
288                   Subject => Subject,
289                   Charset => Charset);
290
291      Set_Text_Part (ES      => ES,
292                     Part    => Text_Part,
293                     Charset => Charset);
294
295      Add_SMTP_Server (ES   => ES,
296                       Host => SMTP_Server,
297                       Port => SMTP_Port);
298
299      Send (ES => ES);
300   end Send;
301
302   ------------
303   --  Send  --
304   ------------
305
306   procedure Send
307     (ES           : in out Structure;
308      From_Address : in     String;
309      From_Name    : in     String := "";
310      To_Address   : in     String;
311      To_Name      : in     String := "";
312      Subject      : in     String;
313      Text_Part    : in     String;
314      HTML_Part    : in     String;
315      SMTP_Server  : in     String := "localhost";
316      SMTP_Port    : in     Positive := 25;
317      Charset      : in     Character_Set := US_ASCII)
318   is
319   begin
320      Set_HTML_Part (ES      => ES,
321                     Part    => HTML_Part,
322                     Charset => Charset);
323
324      Send (ES           => ES,
325            From_Address => From_Address,
326            From_Name    => From_Name,
327            To_Address   => To_Address,
328            To_Name      => To_Name,
329            Subject      => Subject,
330            Text_Part    => Text_Part,
331            SMTP_Server  => SMTP_Server,
332            SMTP_Port    => SMTP_Port,
333            Charset      => Charset);
334   end Send;
335
336   ---------------------
337   --  Set_HTML_Part  --
338   ---------------------
339
340   procedure Set_HTML_Part
341     (ES      : in out Structure;
342      Part    : in     String;
343      Charset : in     Character_Set := US_ASCII)
344   is
345      use GNATCOLL.Email.Utils;
346
347      US : Unbounded_String;
348   begin
349      Encode (Str     => Part,
350              Charset => Get_Charset (Charset => Charset),
351              Result  => US);
352
353      ES.HTML_Part.Content := US;
354      ES.HTML_Part.Charset := Charset;
355
356      ES.Has_HTML_Part := True;
357   end Set_HTML_Part;
358
359   ------------------
360   --  Set_Sender  --
361   ------------------
362
363   procedure Set_Sender
364     (ES      : in out Structure;
365      Address : in     String;
366      Name    : in     String := "";
367      Charset : in     Character_Set := US_ASCII)
368   is
369   begin
370      ES.Sender.Address := U (Address);
371      ES.Sender.Charset := Charset;
372      ES.Sender.Name    := U (Name);
373   end Set_Sender;
374
375   -------------------
376   --  Set_Subject  --
377   -------------------
378
379   procedure Set_Subject
380     (ES      : in out Structure;
381      Subject : in     String;
382      Charset : in     Character_Set := US_ASCII)
383   is
384   begin
385      ES.Subject.Content := U (Subject);
386      ES.Subject.Charset := Charset;
387   end Set_Subject;
388
389   ---------------------
390   --  Set_Text_Part  --
391   ---------------------
392
393   procedure Set_Text_Part
394     (ES      : in out Structure;
395      Part    : in     String;
396      Charset : in     Character_Set := US_ASCII)
397   is
398      use GNATCOLL.Email.Utils;
399
400      US : Unbounded_String;
401   begin
402      Encode (Str     => Part,
403              Charset => Get_Charset (Charset => Charset),
404              Result  => US);
405
406      ES.Text_Part.Content := US;
407      ES.Text_Part.Charset := Charset;
408
409      ES.Has_Text_Part := True;
410   end Set_Text_Part;
411
412end Yolk.Email.Composer;