------------------------------------------------------------------------------
--                              Ada Web Server                              --
--                                                                          --
--                     Copyright (C) 2012-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 --
--  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.Unchecked_Deallocation;

pragma Warnings (Off, "is an internal GNAT unit");
with Ada.Strings.Unbounded.Aux;
pragma Warnings (On, "is an internal GNAT unit");

with AWS.Default;
with AWS.Headers;
with AWS.Messages;
with AWS.Net.WebSocket.Protocol.Draft76;
with AWS.Net.WebSocket.Protocol.RFC6455;
with AWS.Response;
with AWS.Status.Set;
with AWS.Translator;
with AWS.URL;

package body AWS.Net.WebSocket is

   WS_UID : Utils.Counter (0);
   --  Unique Id for the WebSockets

   type Protocol_State is record
      State : Net.WebSocket.Protocol.State_Class;
   end record;

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
     (AWS.Client.HTTP_Connection, AWS.Client.HTTP_Connection_Access);

   procedure Unchecked_Free is new Unchecked_Deallocation
     (Net.WebSocket.Protocol.State'Class,
      Net.WebSocket.Protocol.State_Class);

   procedure Initialize
      (Self     : in out Object'Class;
       Socket   : Socket_Access;
       Protocol : Net.WebSocket.Protocol.State_Class;
       Headers  : AWS.Headers.List);
   --  Initialize the fields of Self

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

   procedure Close
     (Socket  : in out Object;
      Message : String;
      Error   : Error_Type := Normal_Closure) is
   begin
      --  When the user explicitly closes a web socket, we do not call
      --  On_Close (this is only called when the other end closes the socket)

      Socket.P_State.State.Close (Socket, Message, Error_Code (Error));
   exception
      when AWS.Net.Socket_Error =>
         null;
   end Close;

   -------------
   -- Connect --
   -------------

   procedure Connect
     (Socket : in out Object'Class;
      URI    : String)
   is
      URL      : constant AWS.URL.Object := AWS.URL.Parse (URI);
      Headers  : AWS.Headers.List := AWS.Headers.Empty_List;
      Resp     : AWS.Response.Data;
      Protocol : Net.WebSocket.Protocol.State_Class;
   begin
      --  Initially, the connection is initiated with standard http GET

      Socket.Connection := new AWS.Client.HTTP_Connection;
      Protocol := new Net.WebSocket.Protocol.RFC6455.State;

      AWS.Client.Create
        (Socket.Connection.all,
         Host        => URI,
         User        => AWS.Client.No_Data,
         Pwd         => AWS.Client.No_Data,
         Proxy       => AWS.Client.No_Data,
         Proxy_User  => AWS.Client.No_Data,
         Proxy_Pwd   => AWS.Client.No_Data,
         Persistent  => False,
         Certificate => AWS.Default.Client_Certificate,
         Timeouts    => AWS.Client.No_Timeout);

      Protocol.Add_Connect_Headers (AWS.URL.Host (URL), Headers);

      AWS.Client.Get
        (Socket.Connection.all,
         Result      => Resp,
         URI         => AWS.Client.No_Data,
         Data_Range  => AWS.Client.No_Range,
         Headers     => Headers);

      if not Protocol.Check_Connect_Response (Headers, Resp) then
         Unchecked_Free (Protocol);
         Unchecked_Free (Socket.Connection);
         raise AWS.Client.Protocol_Error with "Invalid accept from server";
      end if;

      Initialize
         (Socket,
          AWS.Client.Get_Socket (Socket.Connection.all),
          Protocol,
          Headers);
      AWS.Status.Set.Request (Socket.Request, "GET", URI, "1.1");

      Socket.On_Open ("WebSocket connected with " & URI);
   end Connect;

   ------------
   -- Create --
   ------------

   function Create
     (Socket  : Socket_Access;
      Request : AWS.Status.Data) return Object'Class
   is
      Result   : Object;
      Protocol : Net.WebSocket.Protocol.State_Class;
      Headers  : constant AWS.Headers.List :=
                   AWS.Status.Header (Request);
   begin
      if Headers.Exist (Messages.Sec_WebSocket_Key1_Token)
        and then Headers.Exist (Messages.Sec_WebSocket_Key2_Token)
      then
         Protocol := new Net.WebSocket.Protocol.Draft76.State;
      else
         Protocol := new Net.WebSocket.Protocol.RFC6455.State;
      end if;

      Initialize (Result, Socket, Protocol, Headers);
      Result.Request := Request;
      return Result;
   end Create;

   --------------------
   -- End_Of_Message --
   --------------------

   function End_Of_Message (Socket : Object) return Boolean is
   begin
      return Socket.P_State.State.End_Of_Message;
   end End_Of_Message;

   -----------
   -- Errno --
   -----------

   overriding function Errno (Socket : Object) return Integer is
      use type Interfaces.Unsigned_16;
      E : constant Interfaces.Unsigned_16 := Socket.State.Errno;
   begin
      if E = Interfaces.Unsigned_16'Last then
         return Socket.Socket.Errno;
      else
         Socket.State.Errno := Interfaces.Unsigned_16'Last;
         return Integer (E);
      end if;
   end Errno;

   -----------
   -- Error --
   -----------

   function Error (Socket : Object) return Error_Type is
   begin
      case Socket.State.Errno is
         when 1000   => return Normal_Closure;
         when 1001   => return Going_Away;
         when 1002   => return Protocol_Error;
         when 1003   => return Unsupported_Data;
         when 1005   => return No_Status_Received;
         when 1006   => return Abnormal_Closure;
         when 1007   => return Invalid_Frame_Payload_Data;
         when 1008   => return Policy_Violation;
         when 1009   => return Message_Too_Big;
         when 1010   => return Mandatory_Extension;
         when 1011   => return Internal_Server_Error;
         when 1015   => return TLS_Handshake;
         when others => return Cannot_Resolve_Error;
      end case;
   end Error;

   ----------
   -- Free --
   ----------

   overriding procedure Free (Socket : in out Object) is
      use type AWS.Client.HTTP_Connection_Access;
      procedure Unchecked_Free is
         new Unchecked_Deallocation (Internal_State, Internal_State_Access);
      procedure Unchecked_Free is
         new Unchecked_Deallocation (Protocol_State, Protocol_State_Access);
   begin
      Unchecked_Free (Socket.State);

      if Socket.P_State /= null then
         Unchecked_Free (Socket.P_State.State);
         Unchecked_Free (Socket.P_State);
      end if;

      if Socket.Connection /= null then
         --  Also closes Socket.Socket, since it is shared
         Unchecked_Free (Socket.Connection);
      else
         Free (Socket.Socket);
      end if;

      Free (Socket.Mem_Sock);
   end Free;

   --------------
   -- Get_Addr --
   --------------

   overriding function Get_Addr (Socket : Object) return String is
   begin
      return Socket.Socket.Get_Addr;
   end Get_Addr;

   ------------
   -- Get_FD --
   ------------

   overriding function Get_FD (Socket : Object) return FD_Type is
   begin
      return Socket.Socket.Get_FD;
   end Get_FD;

   --------------
   -- Get_Port --
   --------------

   overriding function Get_Port (Socket : Object) return Positive is
   begin
      return Socket.Socket.Get_Port;
   end Get_Port;

   -----------------------------
   -- Get_Receive_Buffer_Size --
   -----------------------------

   overriding function Get_Receive_Buffer_Size
     (Socket : Object) return Natural is
   begin
      return Socket.Socket.Get_Receive_Buffer_Size;
   end Get_Receive_Buffer_Size;

   --------------------------
   -- Get_Send_Buffer_Size --
   --------------------------

   overriding function Get_Send_Buffer_Size (Socket : Object) return Natural is
   begin
      return Socket.Socket.Get_Send_Buffer_Size;
   end Get_Send_Buffer_Size;

   -------------
   -- Get_UID --
   -------------

   function Get_UID (Socket : Object) return UID is
   begin
      return Socket.Id;
   end Get_UID;

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

   procedure Initialize
      (Self     : in out Object'Class;
       Socket   : Socket_Access;
       Protocol : Net.WebSocket.Protocol.State_Class;
       Headers  : AWS.Headers.List)
   is
      Version      : Natural := 0;
      WS_UID_Value : Natural := 0;
   begin
      if Headers.Exist (Messages.Sec_WebSocket_Version_Token) then
         declare
            Value : constant String :=
                      Headers.Get (Messages.Sec_WebSocket_Version_Token);
         begin
            if Utils.Is_Number (Value) then
               Version := Natural'Value (Value);
            end if;
         end;
      end if;

      WS_UID.Increment (Value => WS_UID_Value);

      Self.Socket   := Socket;
      Self.Id       := UID (WS_UID_Value);
      Self.Version  := Version;
      Self.State    := new Internal_State'
         (Kind          => Unknown,
          Errno         => Interfaces.Unsigned_16'Last,
          Last_Activity => Calendar.Clock);
      Self.P_State  := new Protocol_State'(State => Protocol);
      Self.Mem_Sock := null;
      Self.In_Mem   := False;
   end Initialize;

   ------------------
   -- Is_Listening --
   ------------------

   overriding function Is_Listening (Socket : Object) return Boolean is
      pragma Unreferenced (Socket);
   begin
      return False;
   end Is_Listening;

   ----------
   -- Kind --
   ----------

   function Kind (Socket : Object) return Kind_Type is
   begin
      return Socket.State.Kind;
   end Kind;

   ----------------
   -- On_Message --
   ----------------

   procedure On_Message (Socket : in out Object; Message : Unbounded_String) is
   begin
      On_Message (Object'Class (Socket), To_String (Message));
   end On_Message;

   ------------
   -- Origin --
   ------------

   function Origin (Socket : Object) return String is
   begin
      return Headers.Get
        (AWS.Status.Header (Socket.Request), Messages.Origin_Token);
   end Origin;

   ---------------
   -- Peer_Addr --
   ---------------

   overriding function Peer_Addr (Socket : Object) return String is
   begin
      return Socket.Socket.Peer_Addr;
   end Peer_Addr;

   ---------------
   -- Peer_Port --
   ---------------

   overriding function Peer_Port (Socket : Object) return Positive is
   begin
      return Socket.Socket.Peer_Port;
   end Peer_Port;

   -------------
   -- Pending --
   -------------

   overriding function Pending
     (Socket : Object) return Stream_Element_Count is
   begin
      return Socket.Socket.Pending;
   end Pending;

   ----------
   -- Poll --
   ----------

   function Poll
     (Socket  : in out Object'Class;
      Timeout : Duration)
      return Boolean
   is
      procedure Do_Receive
         (Socket : Object'Class;
          Data   : out Ada.Streams.Stream_Element_Array;
          Last   : out Ada.Streams.Stream_Element_Offset);
      --  Fetch available data on the socket

      ----------------
      -- Do_Receive --
      ----------------

      procedure Do_Receive
         (Socket : Object'Class;
          Data   : out Ada.Streams.Stream_Element_Array;
          Last   : out Ada.Streams.Stream_Element_Offset) is
      begin
         Socket.Receive (Data, Last);
      end Do_Receive;

      function Read_Message is new AWS.Net.WebSocket.Read_Message
        (Receive => Do_Receive);

      Event : AWS.Net.Event_Set;
      Msg   : Unbounded_String;
   begin
      Event := Socket.Poll
         ((AWS.Net.Input => True, others => False), Timeout => Timeout);

      if Event (AWS.Net.Input) then
         --  Block until we have received all chunks of the frame

         loop
            exit when Read_Message (Socket, Msg);
         end loop;

         return True;

      elsif Event (AWS.Net.Error) then
         Socket.On_Error ("Socket error");
      end if;

      return False;

   exception
      when AWS.Net.Socket_Error =>
         --  Socket has been closed
         return False;
   end Poll;

   ----------------------
   -- Protocol_Version --
   ----------------------

   function Protocol_Version (Socket : Object) return Natural is
   begin
      return Socket.Version;
   end Protocol_Version;

   ------------------
   -- Read_Message --
   ------------------

   function Read_Message
     (WebSocket : in out Object'Class;
      Message   : in out Unbounded_String)
      return Boolean
   is
      Data : Stream_Element_Array (1 .. 4_096);
      Last : Stream_Element_Offset;
   begin
      begin
         WebSocket.Receive (Data, Last);
      exception
         when E : Socket_Error =>
            --  FD = No_Socket means Websocket is already closed
            --  and unregistered in other task

            if WebSocket.Get_FD /= Net.No_Socket then
               WebSocket_Exception
                 (WebSocket,
                  Exception_Message (E),
                  Abnormal_Closure);
               On_Error (WebSocket);
            end if;

            return True;
      end;

      case WebSocket.Kind is
         when Text | Binary =>
            Append
              (Message,
               Translator.To_String (Data (Data'First .. Last)));

            if WebSocket.End_Of_Message then
               --  Validate the message as being valid UTF-8 string

               if WebSocket.Kind = Text
                 and then not Utils.Is_Valid_UTF8 (Message)
               then
                  On_Error (WebSocket);
                  WebSocket.On_Close (To_String (Message));
                  WebSocket.Shutdown;
               else
                  WebSocket.On_Message (Message);
                  On_Success (WebSocket);
               end if;

               return True;
            end if;

         when Connection_Close =>
            On_Error (WebSocket);
            WebSocket.On_Close (To_String (Message));
            WebSocket.Shutdown;
            return True;

         when Ping | Pong =>
            if WebSocket.End_Of_Message then
               On_Success (WebSocket);
               return True;
            end if;

         when Connection_Open =>
            --  Note that the On_Open message has been handled at the
            --  time the WebSocket was registered.
            return True;

         when Unknown =>
            On_Error (WebSocket);
            WebSocket.On_Error ("Unknown frame type");
            WebSocket.On_Close ("Unknown frame type");
            WebSocket.Shutdown;
            return True;
      end case;

      return False;
   end Read_Message;

   -------------
   -- Receive --
   -------------

   overriding procedure Receive
     (Socket : Object;
      Data   : out Stream_Element_Array;
      Last   : out Stream_Element_Offset) is
   begin
      Socket.P_State.State.Receive (Socket, Data, Last);
      Socket.State.Last_Activity := Calendar.Clock;
   end Receive;

   -------------
   -- Request --
   -------------

   function Request (Socket : Object) return AWS.Status.Data is
   begin
      return Socket.Request;
   end Request;

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

   overriding procedure Send
     (Socket : Object;
      Data   : Stream_Element_Array;
      Last   : out Stream_Element_Offset) is
   begin
      if Socket.In_Mem then
         Socket.Mem_Sock.Send (Data, Last);
      else
         Socket.Socket.Send (Data, Last);
      end if;

      Socket.State.Last_Activity := Calendar.Clock;
   end Send;

   procedure Send
     (Socket    : in out Object;
      Message   : String;
      Is_Binary : Boolean := False)
   is
      A : Stream_Element_Array
         (Stream_Element_Offset (Message'First) ..
          Stream_Element_Offset (Message'Last)) with Import;
      for A'Address use Message'Address;
   begin
      Send (Socket, A, Is_Binary);
   end Send;

   procedure Send
     (Socket    : in out Object;
      Message   : Unbounded_String;
      Is_Binary : Boolean := False)
   is
      use Ada.Strings.Unbounded.Aux;
      S  : Big_String_Access;
      L  : Natural;
   begin
      Get_String (Message, S, L);
      Send (Socket, String (S (1 .. L)), Is_Binary);
   end Send;

   procedure Send
     (Socket    : in out Object;
      Message   : Stream_Element_Array;
      Is_Binary : Boolean := True) is
   begin
      Socket.State.Kind := (if Is_Binary then Binary else Text);
      Socket.P_State.State.Send (Socket, Message);
   end Send;

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

   overriding procedure Shutdown
     (Socket : Object;
      How    : Shutmode_Type := Shut_Read_Write) is
   begin
      if Socket.Socket /= null then
         Socket.Socket.Shutdown (How);
      end if;
   end Shutdown;

   ------------------
   -- To_Reference --
   ------------------

   function To_Reference (Socket : Object'Class) return Object_Class is
      Result : Object_Class;
   begin
      Result.Set (Socket);
      return Result;
   end To_Reference;

   ---------
   -- URI --
   ---------

   function URI (Socket : Object) return String is
   begin
      return AWS.Status.URI (Socket.Request);
   end URI;

   -------------------------
   -- WebSocket_Exception --
   -------------------------

   procedure WebSocket_Exception
     (WebSocket : in out Object'Class;
      Message   : String;
      Error     : Error_Type) is
   begin
      WebSocket.State.Errno := Error_Code (Error);
      WebSocket.On_Error (Message);

      if Error /= Abnormal_Closure then
         WebSocket.On_Close (Message);
      end if;

      WebSocket.Shutdown;
   exception
      when others =>
         --  Never propagate an exception at this point
         null;
   end WebSocket_Exception;

end AWS.Net.WebSocket;
