File : src/aws-smtp-client.adb


------------------------------------------------------------------------------
--                              Ada Web Server                              --
--                   S M T P - Simple Mail Transfer Protocol                --
--                                                                          --
--                         Copyright (C) 2000-2004                          --
--                                ACT-Europe                                --
--                                                                          --
--  Authors: Dmitriy Anisimkov - Pascal Obry                                --
--                                                                          --
--  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 to 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.                                     --
------------------------------------------------------------------------------

--  $Id: aws-smtp-client.adb,v 1.6 2004/04/06 12:25:49 obry Exp $

with Ada.Calendar;
with Ada.Text_IO;
with Ada.Exceptions;
with Ada.Streams.Stream_IO;

with GNAT.Calendar.Time_IO;

with AWS.Net.Buffered;
with AWS.OS_Lib;
with AWS.Translator;

package body AWS.SMTP.Client is

   use Ada;

   --
   --  Status codes in server replies
   --

   type Server_Reply is record
      Code   : Reply_Code;
      Reason : Unbounded_String;
   end record;

   function Image (Answer : in Server_Reply) return String;
   --  Returns the string representation for Answer.

   procedure Check_Answer
     (Sock  : in     Net.Socket_Type'Class;
      Reply :    out Server_Reply);
   --  Read a reply from the SMTP server (listening on Sock) and fill the Reply
   --  structure.

   procedure Add (Answer : in out Server_Reply; Status : in out SMTP.Status);
   --  Add status code and reason to the list of server's reply.

   procedure Open
     (Server : in     Receiver;
      Sock   :    out Net.Socket_Access;
      Status :    out SMTP.Status);
   --  Open session with a SMTP server

   procedure Close
     (Sock   : in out Net.Socket_Access;
      Status : in out SMTP.Status);
   --  Close session with the SMTP server.

   procedure Output_Header
     (Sock     : in     Net.Socket_Type'Class;
      From     : in     E_Mail_Data;
      To       : in     Recipients;
      Subject  : in     String;
      Status   :    out SMTP.Status;
      Complete : in     Boolean := True);
   --  Output SMTP headers (MAIL, RCPT, DATA, From, To, Subject, Date)

   procedure Output_MIME_Header
     (Sock     : in     Net.Socket_Type'Class;
      Boundary :    out Unbounded_String);
   --  Output MIME SMTP headers, return the MIME boundary

   procedure Put_Translated_Line
     (Sock : in Net.Socket_Type'Class;
      Text : in String);
   --  Translate a leading dot to two dots

   procedure Terminate_Mail_Data (Sock : in out Net.Socket_Type'Class);
   --  Send string CRLF & '.' & CRLF

   procedure Send_MIME_Attachment
     (Sock : in Net.Socket_Type'Class; File : in Attachment);
   --  Send file Filename as a MIME attachment. This procedure send the MIME
   --  attachment headers but does not send the MIME boundary.

   procedure Send_MIME_Message
     (Sock : in Net.Socket_Type'Class; Message : in String);
   --  Send textual message as a MIME content. This procedure send the
   --  MIME headers but does not send the MIME boundary.

   procedure Shutdown (Sock : in out Net.Socket_Access);
   --  Shutdown and close the socket. Do not raise an exception if the Socket
   --  is not connected.

   ---------
   -- Add --
   ---------

   procedure Add (Answer : in out Server_Reply; Status : in out SMTP.Status) is
   begin
      if Status.Value /= Null_Unbounded_String then
         Append (Status.Value, ASCII.LF);
      end if;

      Append (Status.Value, Image (Answer));

      Status.Code := Answer.Code;
   end Add;

   -----------------
   -- Base64_Data --
   -----------------

   function Base64_Data (Name, Content : in String) return Attachment is
   begin
      return (Base64_Data,
              To_Unbounded_String (Name), To_Unbounded_String (Content));
   end Base64_Data;

   ------------------
   -- Check_Answer --
   ------------------

   procedure Check_Answer
     (Sock  : in     Net.Socket_Type'Class;
      Reply :    out Server_Reply)
   is
      Buffer : constant String := Net.Buffered.Get_Line (Sock);
   begin
      Reply :=
        (Reply_Code'Value (Buffer (Buffer'First .. Buffer'First + 2)),
         To_Unbounded_String (Buffer (Buffer'First + 4 .. Buffer'Last)));
   end Check_Answer;

   -----------
   -- Close --
   -----------

   procedure Close
     (Sock   : in out Net.Socket_Access;
      Status : in out SMTP.Status)
   is
      Answer : Server_Reply;
   begin
      Net.Buffered.Put_Line (Sock.all, "QUIT");

      Check_Answer (Sock.all, Answer);

      if Answer.Code /= Service_Closing then
         Add (Answer, Status);
      end if;

      Net.Buffered.Shutdown (Sock.all);
      Net.Free (Sock);
   end Close;

   ----------
   -- File --
   ----------

   function File (Filename : in String) return Attachment is
   begin
      return (File, To_Unbounded_String (Filename));
   end File;

   -----------
   -- Image --
   -----------

   function Image (Answer : in Server_Reply) return String is
      Code_Image : constant String := Reply_Code'Image (Answer.Code);
   begin
      return Code_Image (Code_Image'First + 1 .. Code_Image'Last)
        & ' '
        & To_String (Answer.Reason);
   end Image;

   ----------------
   -- Initialize --
   ----------------

   function Initialize
     (Server_Name : in String;
      Port        : in Positive := Default_SMTP_Port)
      return Receiver is
   begin
      return (To_Unbounded_String (Server_Name), Port, null);
   end Initialize;

   ----------
   -- Open --
   ----------

   procedure Open
     (Server : in     Receiver;
      Sock   :    out Net.Socket_Access;
      Status :    out SMTP.Status)
   is
      Answer : Server_Reply;
   begin
      --  Clear status code
      Clear (Status);

      --  Open server
      Sock := Net.Socket (Security => False);

      Net.Connect (Sock.all, To_String (Server.Name), Server.Port);

      --  Check connect message
      Check_Answer (Sock.all, Answer);

      if Answer.Code = Service_Ready then

         --  Open session
         Net.Buffered.Put_Line
           (Sock.all, "HELO " & Net.Host_Name);
         Check_Answer (Sock.all, Answer);

         --  If no success, close the connection

         if Answer.Code /= Requested_Action_Ok then
            Add (Answer, Status);
            Shutdown (Sock);
         end if;

      else
         Add (Answer, Status);
         Shutdown (Sock);
      end if;
   end Open;

   -------------------
   -- Output_Header --
   -------------------

   procedure Output_Header
     (Sock     : in     Net.Socket_Type'Class;
      From     : in     E_Mail_Data;
      To       : in     Recipients;
      Subject  : in     String;
      Status   :    out SMTP.Status;
      Complete : in     Boolean := True)
   is
      function Current_Date return String;
      --  Returns current date and time for SMTP "Date:" field.

      ------------------
      -- Current_Date --
      ------------------

      function Current_Date return String is
      begin
         --  Format is: Mon, 1 Jan 2002 12:00:00
         return GNAT.Calendar.Time_IO.Image
           (Calendar.Clock, "%a, %-d %b %Y %T");
      end Current_Date;

      Answer : Server_Reply;

   begin
      --  MAIL
      Net.Buffered.Put_Line
        (Sock, "MAIL FROM:<" & Image (From, Address) & '>');

      Check_Answer (Sock, Answer);

      if Answer.Code = Requested_Action_Ok then

         --  RCPT
         for K in To'Range loop
            Net.Buffered.Put_Line
              (Sock,
               "RCPT TO:<" & Image (To (K), Address) & '>');

            Check_Answer (Sock, Answer);

            if Answer.Code /= Requested_Action_Ok then
               Add (Answer, Status);
            end if;
         end loop;

         if Is_Ok (Status) then

            --  DATA
            Net.Buffered.Put_Line (Sock, "DATA");
            Check_Answer (Sock, Answer);

            if Answer.Code = Start_Mail_Input then

               --  Time Stamp
               Net.Buffered.Put_Line (Sock, "Date: " & Current_Date);

               --  From
               Net.Buffered.Put_Line (Sock, "From: " & Image (From));

               --  Subject
               Net.Buffered.Put_Line (Sock, "Subject: " & Subject);

               --  To
               Net.Buffered.Put (Sock, "To: " & Image (To (To'First)));

               for K in To'First + 1 .. To'Last loop
                  Net.Buffered.Put (Sock, ", " & Image (To (K)));
               end loop;

               Net.Buffered.New_Line (Sock);

               if Complete then
                  Net.Buffered.New_Line (Sock);
               end if;

            else
               --  Not possible to send mail header data.
               Add (Answer, Status);
            end if;
         end if;

      else
         --  Error in From address
         Add (Answer, Status);
      end if;
   end Output_Header;

   --------------------------
   -- Output_MIME_Boundary --
   --------------------------

   procedure Output_MIME_Header
     (Sock     : in     Net.Socket_Type'Class;
      Boundary :    out Unbounded_String)
   is
      L_Boundary : constant String
        := GNAT.Calendar.Time_IO.Image (Calendar.Clock, "----=_NextPart_%s");
   begin
      Boundary := To_Unbounded_String (L_Boundary);

      Net.Buffered.Put_Line (Sock, "MIME-Version: 1.0 (produced by AWS/SMTP)");
      Net.Buffered.Put_Line (Sock, "Content-Type: multipart/mixed;");
      Net.Buffered.Put_Line (Sock, "    boundary =""" & L_Boundary & '"');
      Net.Buffered.New_Line (Sock);
   end Output_MIME_Header;

   -------------------------
   -- Put_Translated_Line --
   -------------------------

   procedure Put_Translated_Line
     (Sock : in Net.Socket_Type'Class;
      Text : in String) is
   begin
      if Text'Length > 0 and then Text (Text'First) = '.' then
         Net.Buffered.Put (Sock, ".");
      end if;

      Net.Buffered.Put_Line (Sock, Text);
   end Put_Translated_Line;

   ----------
   -- Send --
   ----------

   procedure Send
     (Server  : in     Receiver;
      From    : in     E_Mail_Data;
      To      : in     E_Mail_Data;
      Subject : in     String;
      Message : in     String;
      Status  :    out SMTP.Status) is
   begin
      Send (Server, From, Recipients'(1 => To), Subject, Message, Status);
   end Send;

   ----------
   -- Send --
   ----------

   procedure Send
     (Server      : in     Receiver;
      From        : in     E_Mail_Data;
      To          : in     E_Mail_Data;
      Subject     : in     String;
      Message     : in     String;
      Attachments : in     Attachment_Set;
      Status      :    out SMTP.Status)
   is
   begin
      Send (Server, From, Recipients'(1 => To),
            Subject, Message, Attachments, Status);
   end Send;

   ----------
   -- Send --
   ----------

   procedure Send
     (Server   : in     Receiver;
      From     : in     E_Mail_Data;
      To       : in     E_Mail_Data;
      Subject  : in     String;
      Filename : in     Message_File;
      Status   :    out SMTP.Status)
   is
      Buffer : String (1 .. 2_048);
      Last   : Natural;
      File   : Text_IO.File_Type;

      Sock   : Net.Socket_Access;
      Answer : Server_Reply;
   begin
      --  Open server
      Open (Server, Sock, Status);

      if Is_Ok (Status) then

         Output_Header (Sock.all, From, Recipients'(1 => To), Subject, Status);

         if Is_Ok (Status) then
            --  Message body
            Text_IO.Open (File, Text_IO.In_File, String (Filename));

            while not Text_IO.End_Of_File (File) loop
               Text_IO.Get_Line (File, Buffer, Last);
               Put_Translated_Line (Sock.all, Buffer (1 .. Last));
            end loop;

            Text_IO.Close (File);

            Terminate_Mail_Data (Sock.all);

            Check_Answer (Sock.all, Answer);

            if Answer.Code /= Requested_Action_Ok then
               Add (Answer, Status);
            end if;
         end if;

         Close (Sock, Status);
      end if;

   exception
      --  Raise Server_Error for all problems encountered

      when E : others =>
         Shutdown (Sock);

         if Text_IO.Is_Open (File) then
            Text_IO.Close (File);
         end if;

         Ada.Exceptions.Raise_Exception
           (Server_Error'Identity, Ada.Exceptions.Exception_Information (E));

   end Send;

   ----------
   -- Send --
   ----------

   procedure Send
     (Server  : in     Receiver;
      From    : in     E_Mail_Data;
      To      : in     Recipients;
      Subject : in     String;
      Message : in     String;
      Status  :    out SMTP.Status)
   is
      Sock   : Net.Socket_Access;
      Answer : Server_Reply;
   begin
      Open (Server, Sock, Status);

      if Is_Ok (Status) then

         Output_Header (Sock.all, From, To, Subject, Status);

         if Is_Ok (Status) then
            --  Message body
            Put_Translated_Line (Sock.all, Message);

            Terminate_Mail_Data (Sock.all);

            Check_Answer (Sock.all, Answer);

            if Answer.Code /= Requested_Action_Ok then
               Add (Answer, Status);
            end if;

         end if;

         Close (Sock, Status);
      end if;

   exception
      --  Raise Server_Error for all problems encountered

      when E : others =>
         Shutdown (Sock);

         Ada.Exceptions.Raise_Exception
           (Server_Error'Identity, Ada.Exceptions.Exception_Information (E));

   end Send;

   ----------
   -- Send --
   ----------

   procedure Send
     (Server      : in     Receiver;
      From        : in     E_Mail_Data;
      To          : in     Recipients;
      Subject     : in     String;
      Message     : in     String;
      Attachments : in     Attachment_Set;
      Status      :    out SMTP.Status)
   is
      Sock     : Net.Socket_Access;
      Answer   : Server_Reply;
      Boundary : Unbounded_String;
   begin
      Open (Server, Sock, Status);

      if Is_Ok (Status) then

         Output_Header
           (Sock.all, From, To, Subject, Status, Complete => False);

         if Is_Ok (Status) then
            --  Send MIME header

            Output_MIME_Header (Sock.all, Boundary);

            --  Message for non-MIME compliant Mail reader

            Net.Buffered.Put_Line
              (Sock.all, "This is multipart MIME message");
            Net.Buffered.Put_Line
              (Sock.all,
               "If you read this, your mailer does not support MIME");
            Net.Buffered.New_Line (Sock.all);

            --  Message body as the first MIME content

            Net.Buffered.Put_Line (Sock.all, "--" & To_String (Boundary));

            Send_MIME_Message (Sock.all, Message);

            --  Send attachments

            Net.Buffered.New_Line (Sock.all);

            for K in Attachments'Range loop
               Net.Buffered.Put_Line (Sock.all, "--" & To_String (Boundary));

               Send_MIME_Attachment (Sock.all, Attachments (K));
            end loop;

            --  Send termination boundary
            Net.Buffered.New_Line (Sock.all);
            Net.Buffered.Put_Line
              (Sock.all, "--" & To_String (Boundary) & "--");

            Terminate_Mail_Data (Sock.all);

            Check_Answer (Sock.all, Answer);

            if Answer.Code /= Requested_Action_Ok then
               Add (Answer, Status);
            end if;

         end if;

         Close (Sock, Status);
      end if;

   exception
      --  Raise Server_Error for all problem encountered

      when E : others =>
         Shutdown (Sock);

         Ada.Exceptions.Raise_Exception
           (Server_Error'Identity, Ada.Exceptions.Exception_Information (E));
   end Send;

   --------------------------
   -- Send_MIME_Attachment --
   --------------------------

   procedure Send_MIME_Attachment
     (Sock : in Net.Socket_Type'Class; File : in Attachment)
   is
      procedure Send_File;
      --  Send File attachment

      procedure Send_Base64;
      --  Send Base64 attachment content

      Filename      : constant String := To_String (File.Name);
      Base_Filename : constant String := OS_Lib.File_Name (Filename);

      -----------------
      -- Send_Base64 --
      -----------------

      procedure Send_Base64 is
         Chunk_Size  : constant := 60;
         Content_Len : constant Positive := Length (File.Data);
         K           : Positive := 1;
      begin
         while K <= Content_Len loop
            if K + Chunk_Size - 1 > Content_Len then
               Net.Buffered.Put_Line (Sock, Slice (File.Data, K, Content_Len));
               K := Content_Len + 1;
            else
               Net.Buffered.Put_Line
                 (Sock, Slice (File.Data, K, K + Chunk_Size - 1));
               K := K + Chunk_Size;
            end if;
         end loop;

         Net.Buffered.New_Line (Sock);
      end Send_Base64;

      ---------------
      -- Send_File --
      ---------------

      procedure Send_File is
         use Streams;

         Buffer_Size : constant := 60;
         --  Note that this size must be a multiple of 3, this is important to
         --  have proper chunk MIME encoding.

         File   : Stream_IO.File_Type;
         Buffer : Stream_Element_Array (1 .. Buffer_Size);
         Last   : Stream_Element_Offset;
      begin
         Stream_IO.Open (File, Stream_IO.In_File, Filename);

         while not Stream_IO.End_Of_File (File) loop
            Stream_IO.Read (File, Buffer, Last);

            Net.Buffered.Put_Line
              (Sock, AWS.Translator.Base64_Encode (Buffer (1 .. Last)));
         end loop;

         Net.Buffered.New_Line (Sock);

         Stream_IO.Close (File);
      end Send_File;

   begin
      --  MIME attachment headers

      Net.Buffered.Put_Line (Sock, "Content-Type: application/octet-stream;");
      Net.Buffered.Put_Line (Sock, "    name =""" & Base_Filename & '"');
      Net.Buffered.Put_Line (Sock, "Content-Transfer-Encoding: base64");
      Net.Buffered.Put_Line (Sock, "Content-Disposition: attachment;");
      Net.Buffered.Put_Line (Sock, "    filename=""" & Base_Filename & '"');
      Net.Buffered.New_Line (Sock);

      --  MIME content

      case File.Kind is
         when Client.File => Send_File;
         when Base64_Data => Send_Base64;
      end case;
   end Send_MIME_Attachment;

   -----------------------
   -- Send_MIME_Message --
   -----------------------

   procedure Send_MIME_Message
     (Sock : in Net.Socket_Type'Class; Message : in String) is
   begin
      --  MIME message headers

      Net.Buffered.Put_Line (Sock, "Content-Type: text/plain");
      Net.Buffered.New_Line (Sock);

      Put_Translated_Line (Sock, Message);
   end Send_MIME_Message;

   --------------
   -- Shutdown --
   --------------

   procedure Shutdown (Sock : in out Net.Socket_Access) is
      use type Net.Socket_Access;
   begin
      if Sock /= null then
         Net.Buffered.Shutdown (Sock.all);
         Net.Free (Sock);
      end if;
   end Shutdown;

   -------------------------
   -- Terminate_Mail_Data --
   -------------------------

   procedure Terminate_Mail_Data (Sock : in out Net.Socket_Type'Class) is
   begin
      Net.Buffered.New_Line (Sock);
      Net.Buffered.Put (Sock, ".");
      Net.Buffered.New_Line (Sock);
   end Terminate_Mail_Data;

end AWS.SMTP.Client;