------------------------------------------------------------------------------
--                              Ada Web Server                              --
--                                                                          --
--                     Copyright (C) 2008-2023, 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 --
--  MERCHANTABILITY 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   --
--  <http://www.gnu.org/licenses/>.                                         --
--                                                                          --
--  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.Exceptions;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.Text_IO;

with AWS.Headers;
with AWS.Net.Buffered;
with AWS.Net.SSL;
with AWS.SMTP.Messages.Set;

package body AWS.SMTP.Server is

   use Ada;

   --  Messages definitions

   DATA     : constant String := "DATA";
   HELO     : constant String := "HELO";
   MAIL     : constant String := "MAIL";
   QUIT     : constant String := "QUIT";
   RCPT     : constant String := "RCPT";
   STARTTLS : constant String := "STARTTLS";

   function Get_Message (Sock : Net.Socket_Type'Class) return Messages.Data;
   --  Get an incoming message from the server

   ------------------
   -- Mail_Handler --
   ------------------

   task body Mail_Handler is
      Message : Messages.Data;
   begin
      accept Start;

      --  Server.Host.Secure could be used only after accept Start because
      --  task created before Server.Host initialized.

      declare
         Sock : Net.Socket_Type'Class :=
                  Net.Socket (Security => Server.Host.Security = TLS);
      begin
         loop
            AWS.Net.Accept_Socket (Server.Host.Sock.all, Sock);

            Message := Get_Message (Sock);

            Server.Action (Message);

            Sock.Shutdown;
         end loop;
      end;

   exception
      when E : others =>
         if not Server.Shutdown then
            --  When server is shutdown we do not want to report errors. In
            --  some cases the socket layer won't end silently as the server
            --  socket is shutdown. See Shutdown routine below.
            Text_IO.Put_Line ("SMTP Server Fatal error");
            Text_IO.Put_Line (Exceptions.Exception_Information (E));
            raise;
         end if;
   end Mail_Handler;

   -----------------
   -- Get_Message --
   -----------------

   function Get_Message
     (Sock : Net.Socket_Type'Class) return Messages.Data
   is

      S : Net.Socket_Access := new Net.Socket_Type'Class'(Sock);

      Empty_Line : constant String := "";

      procedure Read_Message_Body;
      --  Read message body from the current socket and set the Message_Body
      --  Unbounded String below. A message body is terminated by the sequence
      --  CRLF & '.' & CRLF.

      Message      : Messages.Data;
      Message_Body : Unbounded_String;
      Headers      : AWS.Headers.List;

      -----------------------
      -- Read_Message_Body --
      -----------------------

      procedure Read_Message_Body is
      begin
         Read_Message_Header : loop
            declare
               Line        : constant String :=
                               Net.Buffered.Get_Line (S.all);
               Split_Point : Natural;
            begin
               exit Read_Message_Header when Line = Empty_Line;
               Split_Point := Strings.Fixed.Index (Line, ":");

               Headers.Add
                 (Name  => Line (Line'First .. Split_Point - 1),
                  Value => Line (Split_Point + 2 .. Line'Last));
            end;
         end loop Read_Message_Header;

         --  https://tools.ietf.org/html/rfc5321#section-4.5.2

         Read_Message : loop
            declare
               Line  : constant String := Net.Buffered.Get_Line (S.all);
               First : Natural := Line'First;
            begin
               exit Read_Message when Line = ".";

               if Line'Length > 0 and then Line (Line'First) = '.' then
                  First := First + 1;
               end if;

               Append (Message_Body, Line (First .. Line'Last) & CRLF);
            end;
         end loop Read_Message;
      end Read_Message_Body;

   begin
      Net.Buffered.Put_Line (S.all, SMTP.Message (220));
      --  ok, service is ready

      Read_Message : loop
         declare
            Line : constant String := Net.Buffered.Get_Line (S.all);
            Spc  : constant Natural :=
                     Strings.Fixed.Index
                       (Line, Strings.Maps.To_Set (" "));
            Last : constant Positive :=
                     (if Spc = 0 then Line'Last else Spc - 1);
            Cmd  : constant String :=
                     Line (Line'First .. Last);
         begin
            if Cmd = DATA then
               Net.Buffered.Put_Line
                 (S.all, SMTP.Message (Start_Mail_Input));

               Read_Message_Body;
               Net.Buffered.Put_Line
                 (S.all, SMTP.Message (Requested_Action_Ok));

            elsif Cmd = HELO then
               Net.Buffered.Put_Line
                 (S.all, SMTP.Message (Requested_Action_Ok));

            elsif Cmd = MAIL then
               Net.Buffered.Put_Line
                 (S.all, SMTP.Message (Requested_Action_Ok));

            elsif Cmd = RCPT then
               Net.Buffered.Put_Line
                 (S.all, SMTP.Message (Requested_Action_Ok));

            elsif Cmd = QUIT then
               Net.Buffered.Put_Line
                 (S.all, SMTP.Message (Service_Closing));
               exit Read_Message;

            elsif Cmd = STARTTLS then
               --  And upgrade socket to secure one

               declare
                  S_Sock : constant Net.SSL.Socket_Type :=
                             Net.SSL.Secure_Server (S.all);
               begin
                  Net.Buffered.Put_Line
                    (S.all, SMTP.Message (Service_Ready));
                  Net.Buffered.Flush (S.all);

                  Net.Free (S);
                  S := new Net.Socket_Type'Class'
                    (Net.Socket_Type'Class (S_Sock));
               end;
            else
               --  Command is not known

               Net.Buffered.Put_Line (S.all, SMTP.Message (Syntax_Error));

            end if;
         end;
      end loop Read_Message;

      Net.Buffered.Flush (S.all);

      Messages.Set.Set_Body (Message, To_String (Message_Body));
      Messages.Set.Headers (Message, Headers);

      return Message;
   end Get_Message;

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

   procedure Shutdown (Server : in out Handle) is
      Try : Natural := 5;
   begin
      --  Shutdown the socket, this should raise socket error on the
      --  Mail_Handler task.

      Server.Shutdown := True;

      Net.Shutdown (Server.Host.Sock.all);

      --  Now wait for the task to terminate

      while not Server.Server_Handler'Terminated and then Try > 0 loop
         delay 1.0;
         Try := Try - 1;
      end loop;

      --  If not yet terminated abort

      if not Server.Server_Handler'Terminated then
         abort Server.Server_Handler;
      end if;

      Net.Free (Server.Host.Sock);
   end Shutdown;

   -----------
   -- Start --
   -----------

   procedure Start
     (Server : in out Handle;
      Host   : Receiver;
      Action : Callback) is
   begin
      --  Initialize server listening port

      Server.Host := Host;

      Server.Host.Sock := Net.Socket (Security => False);

      Server.Host.Sock.Set_Timeout (Server.Host.Timeout);
      Server.Host.Sock.Bind (Port => Host.Port, Family => Host.Family);
      Server.Host.Sock.Listen;

      if Host.Port = 0 then
         Server.Host.Port := Server.Host.Sock.Get_Port;
      end if;

      Server.Action := Action;

      Server.Server_Handler.Start;
   end Start;

end AWS.SMTP.Server;
