aws_24.0.0_2b75fe6d/src/core/aws-server.ads

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

pragma Ada_2012;

with Ada.Task_Identification;

with AWS.Config;
with AWS.Default;
with AWS.Dispatchers;
with AWS.Exceptions;
with AWS.Net.Poll_Events;
with AWS.Net.SSL;
with AWS.Net.Std;
with AWS.Response;
with AWS.Status;

private with Ada.Calendar;
private with Ada.Exceptions;
private with Ada.Finalization;
private with Ada.Task_Attributes;
private with Ada.Real_Time;
private with GNATCOLL.Refcount;
private with System;

private with AWS.Log;
private with AWS.Net.Acceptors;
private with AWS.HTTP2.Connection;
private with AWS.HTTP2.HPACK.Table;
private with AWS.Hotplug;
private with AWS.Utils;

package AWS.Server is

   type HTTP is limited private;
   --  A Web server

   ---------------------------
   -- Server initialization --
   ---------------------------

   --  Note that starting a sercure server if AWS has not been configured to
   --  support HTTPS will raise Program_Error.

   procedure Start
     (Web_Server : in out HTTP;
      Callback   : Response.Callback;
      Config     : AWS.Config.Object);
   --  Start server using a full configuration object. With this routine it is
   --  possible to control all features of the server. A simplified version of
   --  Start is also provided below with the most common options.

   procedure Start
     (Web_Server : in out HTTP;
      Dispatcher : Dispatchers.Handler'Class;
      Config     : AWS.Config.Object);
   --  Idem, but using the dispatcher tagged type instead of callback. See
   --  AWS.Services.Dispatchers and AWS.Dispatchers hierarchies for built-in
   --  services and interface to build your own dispatcher models.
   --  Note that a copy of the Dispatcher is keept into Web_Server. Any
   --  changes done to the Dispatcher object will not be part of the Web
   --  server dispatcher.

   procedure Get_Message_Body;
   --  If size of message body is bigger than Upload_Size_Limit configuration
   --  parameter, server do not receive message body before calling user's
   --  callback routine. If user decide to get the message body he should call
   --  this routine.

   procedure Start
     (Web_Server                : in out HTTP;
      Name                      : String;
      Callback                  : Response.Callback;
      Max_Connection            : Positive  := Default.Max_Connection;
      Admin_URI                 : String    := Default.Admin_URI;
      Port                      : Natural   := Default.Server_Port;
      Security                  : Boolean   := False;
      Session                   : Boolean   := False;
      Case_Sensitive_Parameters : Boolean   := True;
      Upload_Directory          : String    := Default.Upload_Directory;
      Line_Stack_Size           : Positive  := Default.Line_Stack_Size);
   --  Start the Web server. Max_Connection is the number of simultaneous
   --  connections the server's will handle (the number of slots in AWS).
   --  Name is just a string used to identify the server. This is used
   --  for example in the administrative page. Admin_URI must be set to enable
   --  the administrative status page. Callback is the procedure to call for
   --  each resource requested. Port is the Web server port. If Security is
   --  set to True the server will use an HTTPS/SSL connection. If Session is
   --  set to True the server will be able to get a status for each client
   --  connected. A session Id is used for that, on the client side it is a
   --  cookie. Case_Sensitive_Parameters if set to False it means that the
   --  parameters name will be handled without case sensitivity. Upload
   --  directory point to a directory where uploaded files will be stored.

   ------------------------
   -- Server termination --
   ------------------------

   procedure Shutdown (Web_Server : in out HTTP);
   --  Stop the server and release all associated memory. This routine can
   --  take some time to terminate because it waits for all tasks to terminate
   --  properly before releasing the memory. The log facilities will be
   --  automatically stopped by calling Stop_Log below.

   type Termination is (No_Server, Q_Key_Pressed, Forever);

   procedure Wait (Mode : Termination := No_Server);
   --  The purpose of this procedure is to control the main procedure
   --  termination. This procedure will return only when no server are running
   --  (No_Server mode) or the 'q' key has been pressed. If mode is set to
   --  Forever, Wait will never return and the process will have to be killed.

   --------------------------
   -- Server configuration --
   --------------------------

   function Config (Web_Server : HTTP) return AWS.Config.Object;
   --  Returns configuration object for Web_Server

   procedure Set_Unexpected_Exception_Handler
     (Web_Server : in out HTTP;
      Handler    : Exceptions.Unexpected_Exception_Handler);
   --  Set the unexpected exception handler. It is called whenever an
   --  unrecoverable error has been detected. The default handler just display
   --  (on standard output) an error message with the location of the
   --  error. By changing this handler it is possible to log or display full
   --  symbolic stack backtrace if needed.

   procedure Set
     (Web_Server : in out HTTP;
      Dispatcher : Dispatchers.Handler'Class);
   --  Dynamically associate a new dispatcher object to the server. With the
   --  feature it is possible to change server behavior at runtime. The
   --  complete set of callback procedures will be changed when calling this
   --  routine. Note that any change in a dispatcher associated with a server
   --  using Register or Unregister must be reset into the server using this
   --  routine.

   procedure Set_Security
     (Web_Server           : in out HTTP;
      Certificate_Filename : String;
      Security_Mode        : Net.SSL.Method := Net.SSL.TLS_Server;
      Key_Filename         : String         := "");
   --  Set security option for AWS. Certificate_Filename is the name of a file
   --  containing a certificate. Key_Filename is the name of the file
   --  containing the key, if the empty string the key will be taken from the
   --  certificate filename. This must be called before starting the secure
   --  server otherwise the default security options or options set in the
   --  config files will be used. After that the call will have no effect.

   procedure Set_SSL_Config
     (Web_Server : in out HTTP; SSL_Config : Net.SSL.Config);
   --  Set the SSL configuration for this server

   function SSL_Config
     (Web_Server : in out HTTP) return not null access Net.SSL.Config;
   --  Returns the access to SSL config of the server. Allow to change SSL
   --  config on the already created server.

   procedure Set_Socket_Constructor
     (Web_Server         : in out HTTP;
      Socket_Constructor : Net.Socket_Constructor);
   --  Set the socket constructor routine to use when creating new sockets on
   --  the server. By calling this routine it is possible to replace the
   --  default AWS communication layer used. The default constructor is
   --  AWS.Net.Socket. Note that this routine must be called before starting
   --  the server. It is also important to note that sockets returned by the
   --  constructor must have the cache properly initialized. See AWS.Net.Cache
   --  for more information.

   type HTTP_Access is access all HTTP;

   function Get_Current return not null access HTTP;
   --  Get current server. This can be used in a callback procedure to
   --  retrieve the running HTTP server. It is needed when a callback
   --  procedure is shared by multiple servers.

   function Get_Status return Status.Data;
   --  Returns the current status data. This is useful to get the full status
   --  in a templates engine callback procedure for example.

   function Session_Name return String;
   --  Returns the current session cookie name

   function Session_Private_Name return String;
   --  Returns the current private session cookie name

   ---------------
   -- Other API --
   ---------------

   procedure Give_Back_Socket
     (Web_Server : in out HTTP; Socket : Net.Socket_Type'Class);
   --  Give the socket back to the server. Socket must have been taken from
   --  the server using the Response.Socket_Taken routine in a callback.

   procedure Give_Back_Socket
     (Web_Server : in out HTTP;
      Socket     : not null Net.Socket_Access);
   --  Idem.
   --  Use Socket_Access to avoid memory reallocation for already allocated
   --  sockets.

   procedure Set_Field (Id, Value : String);
   --  Set the extended log field value for the server the controlling the
   --  current task.

   procedure Skip_Log_Record;
   --  Disable logging only for the current processing request

   procedure Add_Listening
     (Web_Server    : in out HTTP;
      Host          : String;
      Port          : Natural;
      Family        : Net.Family_Type := Net.Family_Unspec;
      Reuse_Address : Boolean         := False;
      IPv6_Only     : Boolean         := False);
   --  Add the binded/listening socket on host, port and protocol family. To be
   --  able to connect web enabled application with others in the internal
   --  network, and then give access for external clients by listening on
   --  externally available address. Also it could be used to bind one server
   --  to IPv4 and IPv6 protocols simultaneously.
   --  IPv6_Only allows restrict IPv6 server to accept only IPv6 connections.

   type Task_Id_Array is
     array (Positive range <>) of Ada.Task_Identification.Task_Id;

   function Line_Tasks (Web_Server : HTTP) return Task_Id_Array;
   --  Returns line tasks identifiers

private

   pragma Warnings
     (Off,
      """Ada"" is already use-visible through previous use_clause at aws-net");
   use Ada;
   pragma Warnings (On);

   pragma Warnings
     (Off,
      """Exceptions"" is already use-visible through previous use_clause at ");
   use Ada.Exceptions;
   pragma Warnings (On);

   procedure Default_Unexpected_Exception_Handler
     (E      : Exception_Occurrence;
      Log    : in out AWS.Log.Object;
      Error  : Exceptions.Data;
      Answer : in out Response.Data);
   --  Default unexpected exception handler

   procedure Socket_Taken;
   --  Mark socket of the cureent line of the current server taken

   ------------
   -- Phases --
   ------------

   type Slot_Phase is
     (Closed,
      --  Socket has been closed on the server side

      In_Shutdown,
      --  Phase when socket is marked in protected Slots for shutdown

      Aborted,
      --  Slot was aborted by means of socket shutdown

      Wait_For_Client,
      --  We can abort keep-alive connection in this stage

      Client_Header,
      --  We can abort keep-alive connection when client header
      --  takes too much time

      Client_Data,
      --  We should think about it. Maybe we should not trust the clients
      --  who are spending too much server time in sending data

      Server_Response,
      --  We are trusting ourselves but client may be too slow purposely in
      --  receiving data and we should disconnect him

      Server_Processing
      --  While in the User defined Dispatch procedure
     );

   subtype Abortable_Phase is Slot_Phase
     range Wait_For_Client .. Server_Response;

   subtype Data_Phase is Abortable_Phase
     range Client_Data .. Server_Response;

   --------------
   -- Timeouts --
   --------------

   type Timeout_Mode is (Cleaner, Force);
   --  This is Force timeouts and timeouts for Line_Cleaner task

   type Timeouts_Array is array (Timeout_Mode, Abortable_Phase) of Duration;

   type Data_Timeouts_Array is array (Data_Phase) of Duration;

   subtype Socket_Access is Net.Socket_Access;

   ----------
   -- Slot --
   ----------

   type Slot is record
      Sock                  : Socket_Access;
      Wait_For_Data         : aliased Net.Poll_Events.Set (2);
      Wait_Receiver         : Net.Std.Socket_Type;
      Wait_Breaker          : Net.Std.Socket_Type;
      Socket_Taken          : Boolean        := False;
      Phase                 : Slot_Phase     := Closed;
      Phase_Time_Stamp      : Real_Time.Time := Real_Time.Clock;
      Alive_Time_Stamp      : Calendar.Time;
      Slot_Activity_Counter : Natural := 0;
      Activity_Counter      : Natural := 0;
      Alive_Counter         : Natural;
   end record;
   --  Wait_For_Data is set of 2 sockets. First is to abort waiting, second is
   --  main socket waiting for start of new client request in the slot.
   --  Wait_Receiver is the first socket in set above.
   --  What Breaker is the socket to send byte will be received by
   --  Wait_Receiver.
   --  Phase_Time_Stamp is the last time when Phase of line has been changed.
   --  The line in Abortable state and with oldest Phase_Time_Stamp could be
   --  closed.

   type Slot_Set is array (Positive range <>) of Slot;

   package CNF renames AWS.Config;

   --  Socket Data used to retrieve safely socket information

   type Socket_Data (Peername_Length : Natural) is record
      Peername : String (1 .. Peername_Length);
      FD       : Integer;
   end record;

   type FD_Set_Access is access all Net.Poll_Events.Set;

   -----------
   -- Slots --
   -----------

   protected type Slots (N : Positive) is

      procedure Mark_Phase (Index : Positive; Phase : Slot_Phase);
      --  Set Activity_Time_Stamp which is the last time where the line number
      --  Index as been used.

      procedure Check_Data_Timeout (Index : Positive);
      --  Check timeout of send/receive message body

      procedure Socket_Taken (Index : Positive);
      --  Used to mark slot associated socket has "taken" by some foreign code.
      --  The server must not close this socket on releasing the slot. It is
      --  used when passing socket to the server push part for example. In the
      --  future it could be used for other functionality over the same
      --  socket, changing HTTP to other protocol for example.

      procedure Prepare_Back (Index : Positive; Possible : out Boolean);
      --  Test and prepare to put socket back into acceptor.
      --  If Possible value become False, it is not possible to
      --  back socket into acceptor because socket already in shutdown process.

      function Is_Abortable (Index : Positive) return Boolean;
      --  Return True when slot can be aborted due to "forced" timeouts

      procedure Abort_On_Timeout
        (Socket : out Socket_Access; Index : in out Positive);
      --  Get the socket pointer from slot where timeout exceeded.
      --  Index IN value is the current slot number, to avoid current slot
      --  abortion.
      --  Index OUT value is the slot number to abort.
      --  Return null if no such sockets.

      function Free_Slots return Natural;
      --  Returns number of free slots

      procedure Set (Socket : not null Net.Socket_Access; Index  : Positive);
      --  Mark slot at position Index to be used. This slot will be associated
      --  with Socket. Phase set to Wait_For_Client.

      procedure Get_Wait_For_Data
        (Index : Positive; Reference : out not null FD_Set_Access);

      procedure Get_For_Shutdown
        (Index : Positive; Socket : out Socket_Access);
      --  Get socket from the slot for shutdown, Slot phase is set to
      --  In_Shutdown.

      procedure Shutdown_Done (Index : Positive);
      --  Called when Shutdown is complete, Slot phase is set to Aborted

      entry Release (Index : Positive; Shutdown : out Boolean);
      --  Release slot number Index. Slot phase is set to Closed.
      --  Set the shutdown flag to True is called task have to
      --  shutdown and free the socket.
      --  Note that calling task is only the Line task,
      --  so the socket need to be shutdown is in the stack on the Line task.

      function Get (Index : Positive) return Slot;
      --  Returns Slot data

      function Phase (Index : Positive) return Slot_Phase;
      --  Returns Slot phase

      function Get_Socket_Info (Index : Positive) return Socket_Data;
      --  Returns information about socket (FD and Peername) associated with
      --  slot Index. If the socket is not opened returns
      --  (FD => 0, Peername => "-")

      function Get_Socket (Index : Positive) return Socket_Access;

      function Get_Peername (Index : Positive) return String;
      --  Returns the peername for socket at position Index

      procedure Increment_Slot_Activity_Counter
        (Index : Positive; Free_Slots : out Natural);
      --  Add 1 to the slot activity. This is the total number of request
      --  handled by the slot.
      --  Returns number of Free slots in the Free_Slot out parameter, it is
      --  necessary information for Server line task to determine is it
      --  necessary to call Force_Clean and to determine keep-alive
      --  availability.

      procedure Set_Timeouts
        (Phase_Timeouts : Timeouts_Array;
         Data_Timeouts  : Data_Timeouts_Array);
      --  Setup timeouts for slots before starting

   private

      Timeouts      : Timeouts_Array;
      Data_Timeouts : Data_Timeouts_Array;

      Table : Slot_Set (1 .. N);
      Count : Natural := N;

      Shutdown_Count : Natural := 0;
      Last_Force     : Calendar.Time := Calendar.Clock;

   end Slots;

   type Slots_Access is access Slots;

   ----------
   -- Line --
   ----------

   task type Line (Priority : System.Any_Priority; Stack_Size : Integer)
     with Priority     => Priority,
          Storage_Size => Stack_Size
   is
      entry Start (Server : HTTP; Index : Positive);
   end Line;

   type Line_Access is access Line;

   type Line_Set is array (Positive range <>) of Line_Access;

   type Line_Set_Access is access Line_Set;

   type HTTP2_Context is record
      Tab_Enc  : aliased HTTP2.HPACK.Table.Object;
      Tab_Dec  : aliased HTTP2.HPACK.Table.Object;
      Settings : aliased HTTP2.Connection.Object;
   end record;

   package HTTP2_Context_References is new GNATCOLL.Refcount.Shared_Pointers
     (HTTP2_Context);

   package H2CR renames HTTP2_Context_References;

   Null_H2_Ref : constant HTTP2_Context_References.Ref := H2CR.Null_Ref;

   package HTTP_Acceptors is new Net.Acceptors (H2CR.Ref, Null_H2_Ref);

   ----------
   -- HTTP --
   ----------

   type HTTP is new Ada.Finalization.Limited_Controlled with record
      Self               : not null access HTTP := HTTP'Unchecked_Access;
      --  Point to the record

      Start_Time         : Calendar.Time;
      --  Date and Time when server was started

      Shutdown           : Boolean := True;
      --  True when server is shutdown. This will be set to False when server
      --  will be started.

      Acceptor           : HTTP_Acceptors.Acceptor_Type;
      --  This is the socket set where server socket and keep alive sockets
      --  waiting for read availability.

      Properties         : CNF.Object := CNF.Get_Current;
      --  All server properties controled by the configuration file

      Log                : AWS.Log.Object;
      --  Logging support

      Error_Log          : aliased AWS.Log.Object;
      --  Error loggin support

      Dispatcher         : Dispatchers.Handler_Class_Access;
      --  Dispatcher for the user actions

      New_Dispatcher     : Dispatchers.Handler_Class_Access;
      --  New dispatcher set in a user's callback, if set this dispatcher will
      --  replace the main dispatcher above.

      Dispatcher_Sem     : Utils.RW_Semaphore (Writers => 1);
      --  RW semaphore to be able to change dynamically the Dispatcher object

      Filters            : Hotplug.Filter_Set;
      --  Hotplug filters are recorded here

      Lines              : Line_Set_Access;
      --  The tasks doing the job

      Slots              : Slots_Access;
      --  Information about each tasks above. This is a protected object to
      --  support concurrency.

      Exception_Handler  : Exceptions.Unexpected_Exception_Handler
         := Default_Unexpected_Exception_Handler'Access;
      --  Exception handle used for unexpected errors found on the server
      --  implementation.

      SSL_Config         : aliased Net.SSL.Config;
   end record;

   overriding procedure Finalize (Web_Server : in out HTTP);

   type Line_Attribute_Record is record
      Server     : access HTTP;
      Line       : Positive;
      Stat       : access Status.Data;
      Expect_100 : Boolean := False;
      Skip_Log   : Boolean := False;
      Log_Data   : Log.Fields_Table;
   end record;

   package Line_Attribute is new Ada.Task_Attributes
     (Line_Attribute_Record, Line_Attribute_Record'(Line => 1, others => <>));
   --  A line specific attribute

   procedure Null_Procedure is null;

   First_Server : not null access procedure := Null_Procedure'Access;
   --  This procedure calls on first server started

   No_Servers   : not null access procedure := Null_Procedure'Access;
   --  This procedure calls on last server shutdown

end AWS.Server;