------------------------------------------------------------------------------
-- Ada Web Server --
-- --
-- Copyright (C) 2000-2022, 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 --
-- . --
-- --
-- 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.Streams;
with Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with AWS.Config.Set;
with AWS.Dispatchers.Callback;
with AWS.Messages;
with AWS.MIME;
with AWS.Net.Buffered;
with AWS.Net.WebSocket.Registry.Control;
with AWS.Server.HTTP_Utils;
with AWS.Server.Log;
with AWS.Services.Transient_Pages.Control;
with AWS.Session.Control;
with AWS.Status.Set;
with AWS.Status.Translate_Set;
with AWS.Templates;
package body AWS.Server is
use type Net.Socket_Access;
procedure Start
(Web_Server : in out HTTP;
Dispatcher : Dispatchers.Handler'Class);
-- Start web server with current configuration
procedure Protocol_Handler (LA : in out Line_Attribute_Record);
-- Handle the lines, this is where all the HTTP/1.1 protocol is defined
procedure Protocol_Handler_V2
(LA : in out Line_Attribute_Record;
Will_Close : out Boolean;
HTTP2_Ref : HTTP2_Context_References.Ref;
Check_Preface : Boolean := True);
-- Handle the lines, this is where all the HTTP/2 protocol is defined
function Next_Request_Or_Give_Back
(LA : in out Line_Attribute_Record;
Sock : Socket_Access;
H2_Ref : HTTP2_Context_References.Ref) return Boolean;
-- Return True if there is something in socket read buffer
function Accept_Socket_Serialized
(Server : not null access HTTP;
Data : out HTTP2_Context_References.Ref)
return not null Net.Socket_Access;
-- Do a protected accept on the HTTP socket. It is not safe to call
-- multiple accept on the same socket on some platforms.
procedure Force_Clean (Web_Server : in out HTTP);
-- Close a socket on a slot for which a force timeout has expired
Server_Counter : Utils.Counter (Initial_Value => 0);
------------------------------
-- Accept_Socket_Serialized --
------------------------------
function Accept_Socket_Serialized
(Server : not null access HTTP;
Data : out HTTP2_Context_References.Ref)
return not null Net.Socket_Access
is
New_Socket : Net.Socket_Access;
procedure Accept_Error (E : Ada.Exceptions.Exception_Occurrence);
function Set_CLOSEXEC
(Sock : Net.Socket_Access) return Net.Socket_Access;
-- Returns Sock with flag close on exec set if the server has
-- this property.
------------------
-- Accept_Error --
------------------
procedure Accept_Error (E : Ada.Exceptions.Exception_Occurrence) is
begin
AWS.Log.Write
(Server.Error_Log,
"Accept error "
& Utils.CRLF_2_Spaces (Ada.Exceptions.Exception_Information (E)));
Force_Clean (Server.all);
end Accept_Error;
------------------
-- Set_CLOSEXEC --
------------------
function Set_CLOSEXEC
(Sock : Net.Socket_Access) return Net.Socket_Access is
begin
if CNF.Close_On_Exec (Server.Properties) then
Net.Set_Close_On_Exec (Sock.all);
end if;
return Sock;
end Set_CLOSEXEC;
begin
loop
HTTP_Acceptors.Get
(Server.Acceptor, New_Socket, Data, Accept_Error'Access);
if CNF.Security (Server.Properties)
and then not New_Socket.Is_Secure
then
declare
SSL_Socket : Net.SSL.Socket_Type;
begin
SSL_Socket := Net.SSL.Secure_Server
(New_Socket.all, Server.SSL_Config);
Net.Free (New_Socket);
SSL_Socket.Do_Handshake; -- Handshake need for HTTP/2 ALPN
pragma Warnings (Off);
return Set_CLOSEXEC (new Net.SSL.Socket_Type'(SSL_Socket));
exception
when Net.Socket_Error =>
if New_Socket = null then
-- It mean error in SSL handshake, shutdown socket and
-- get another one in next iteration.
SSL_Socket.Shutdown;
else
-- Unexpected error
Net.Shutdown (New_Socket.all);
Net.Free (New_Socket);
raise;
end if;
when others =>
Net.Shutdown (New_Socket.all);
Net.Free (New_Socket);
raise;
end;
else
return Set_CLOSEXEC (New_Socket);
end if;
end loop;
end Accept_Socket_Serialized;
-------------------
-- Add_Listening --
-------------------
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) is
begin
HTTP_Acceptors.Add_Listening
(Web_Server.Acceptor, Host, Port, Family, IPv6_Only => IPv6_Only,
Reuse_Address => Reuse_Address);
end Add_Listening;
------------
-- Config --
------------
function Config (Web_Server : HTTP) return AWS.Config.Object is
begin
return Web_Server.Properties;
end Config;
------------------------------------------
-- Default_Unexpected_Exception_Handler --
------------------------------------------
procedure Default_Unexpected_Exception_Handler
(E : Exception_Occurrence;
Log : in out AWS.Log.Object;
Error : Exceptions.Data;
Answer : in out Response.Data)
is
pragma Unreferenced (Log);
use type Templates.Translate_Set;
Fatal_Error_Template : constant String := "500.tmplt";
begin
if Error.Fatal then
Text_IO.Put_Line
(Text_IO.Current_Error, "Fatal error, slot"
& Positive'Image (Error.Slot) & " is dead now.");
Text_IO.New_Line (Text_IO.Current_Error);
Text_IO.Put_Line
(Text_IO.Current_Error, Exception_Information (E));
else
if Utils.Is_Regular_File (Fatal_Error_Template) then
Answer := Response.Build
(MIME.Text_HTML,
String'(Templates.Parse
(Fatal_Error_Template,
Status.Translate_Set (Error.Request)
& Templates.Assoc
("EXCEPTION", Exception_Information (E)))),
Messages.S500);
else
Answer := Response.Build
(MIME.Text_HTML,
"Internal Server Error.
"
& "Please, send the following information to the Web "
& "Master, thanks.
"
& "" & Exception_Information (E) & "
"
& "
",
Messages.S500);
end if;
end if;
end Default_Unexpected_Exception_Handler;
--------------
-- Finalize --
--------------
overriding procedure Finalize (Web_Server : in out HTTP) is
begin
Shutdown (Web_Server);
end Finalize;
-----------------
-- Force_Clean --
-----------------
procedure Force_Clean (Web_Server : in out HTTP) is
Socket : Socket_Access;
Slot : Positive := Line_Attribute.Reference.Line;
-- Initialize the slot by the current slot number to avoid current slot
-- abortion.
begin
Web_Server.Slots.Abort_On_Timeout (Socket, Slot);
if Socket /= null then
Net.Shutdown (Socket.all);
Web_Server.Slots.Shutdown_Done (Slot);
end if;
end Force_Clean;
-----------------
-- Get_Current --
-----------------
function Get_Current return not null access HTTP is
begin
return Line_Attribute.Reference.Server;
end Get_Current;
----------------------
-- Get_Message_Body --
----------------------
procedure Get_Message_Body is
use type Ada.Streams.Stream_Element_Count;
TA : constant Line_Attribute.Attribute_Handle :=
Line_Attribute.Reference;
begin
if not Status.Is_Body_Uploaded (TA.Stat.all)
and then
(Status.Content_Length (TA.Stat.all) > 0
or else Status.Transfer_Encoding (TA.Stat.all) = "chunked")
then
HTTP_Utils.Get_Message_Data
(TA.Server.all, TA.Line, TA.Stat.all, TA.Expect_100);
end if;
end Get_Message_Body;
----------------
-- Get_Status --
----------------
function Get_Status return Status.Data is
begin
return Line_Attribute.Reference.Stat.all;
end Get_Status;
----------------------
-- Give_Back_Socket --
----------------------
procedure Give_Back_Socket
(Web_Server : in out HTTP;
Socket : not null Net.Socket_Access) is
begin
HTTP_Acceptors.Give_Back (Web_Server.Acceptor, Socket);
end Give_Back_Socket;
procedure Give_Back_Socket
(Web_Server : in out HTTP; Socket : Net.Socket_Type'Class) is
begin
Give_Back_Socket (Web_Server, new Net.Socket_Type'Class'(Socket));
end Give_Back_Socket;
----------
-- Line --
----------
task body Line is
TA : constant Line_Attribute.Attribute_Handle :=
Line_Attribute.Reference;
Request : aliased AWS.Status.Data;
begin
select
accept Start
(Server : HTTP;
Index : Positive)
do
TA.Server := Server.Self;
TA.Line := Index;
end Start;
or
terminate;
end select;
-- Real job start here, we will exit only if there is an unrecoverable
-- problem.
while not TA.Server.Shutdown loop
declare
-- Wait for an incoming connection. Each call for the same server
-- is serialized as some platforms do not handle properly
-- multiple accepts on the same socket.
HTTP2_Ref : HTTP2_Context_References.Ref;
Socket : Net.Socket_Access :=
Accept_Socket_Serialized (TA.Server, HTTP2_Ref);
Need_Shutdown : Boolean;
Will_Close : Boolean;
begin
TA.Stat := Request'Unchecked_Access;
if CNF.Send_Buffer_Size (TA.Server.Config) /= 0 then
Net.Set_Send_Buffer_Size
(Socket.all, CNF.Send_Buffer_Size (TA.Server.Config));
end if;
Net.Set_No_Delay (Socket.all, CNF.TCP_No_Delay (TA.Server.Config));
TA.Server.Slots.Set (Socket, TA.Line);
if not HTTP2_Ref.Is_Null then
AWS.Status.Set.Protocol (Request, AWS.Status.H2);
Protocol_Handler_V2
(TA.all, Will_Close, HTTP2_Ref, Check_Preface => False);
elsif Socket.Is_Secure
and then Net.SSL.Socket_Type (Socket.all).ALPN_Get
= Messages.H2_Token
and then CNF.HTTP2_Activated (TA.Server.Config)
then
-- Protocol is secure H2
AWS.Status.Set.Protocol (Request, AWS.Status.H2);
Protocol_Handler_V2 (TA.all, Will_Close, Null_H2_Ref);
else
Protocol_Handler (TA.all);
Will_Close := False;
end if;
TA.Server.Slots.Release (TA.Line, Need_Shutdown);
if Need_Shutdown then
Socket.Shutdown;
-- Don't use Socket.Free, it does not deallocate Socket
Net.Free (Socket);
elsif Will_Close then
TA.Server.Slots.Get_For_Shutdown (TA.Line, Socket);
if Socket /= null then
Socket.Shutdown;
TA.Server.Slots.Shutdown_Done (TA.Line);
end if;
end if;
end;
end loop;
exception
when E : others =>
if not TA.Server.Shutdown then
declare
Answer : Response.Data;
begin
Answer := Response.Build
(Status_Code => Messages.S500,
Content_Type => "text/plain",
Message_Body => Exception_Message (E));
AWS.Log.Write
(TA.Server.Error_Log,
"Dead slot " & Utils.Image (TA.Line) & ' '
& Utils.CRLF_2_Spaces (Exception_Information (E)));
TA.Server.Exception_Handler
(E, TA.Server.Error_Log, (True, TA.Line, Request), Answer);
end;
end if;
end Line;
----------------
-- Line_Tasks --
----------------
function Line_Tasks (Web_Server : HTTP) return Task_Id_Array is
Result : Task_Id_Array (Web_Server.Lines'Range);
begin
for J in Result'Range loop
Result (J) := Web_Server.Lines (J)'Identity;
end loop;
return Result;
end Line_Tasks;
-------------------------------
-- Next_Request_Or_Give_Back --
-------------------------------
function Next_Request_Or_Give_Back
(LA : in out Line_Attribute_Record;
Sock : Socket_Access;
H2_Ref : HTTP2_Context_References.Ref) return Boolean
is
use type AWS.Status.Protocol_State;
use type Ada.Streams.Stream_Element_Count;
Back_OK : Boolean;
Waiter : FD_Set_Access;
Wait_Count : Natural;
Wait : constant Boolean := LA.Server.Slots.Free_Slots >=
CNF.Free_Slots_Keep_Alive_Limit (LA.Server.Properties);
begin
-- If there are few slots available and we have many of them, try to
-- release one of them.
if LA.Server.Slots.N > 1 and then not Wait then
Force_Clean (LA.Server.all);
end if;
if Net.Buffered.Pending (Sock.all) > 0 then
return True;
end if;
if Wait then
LA.Server.Slots.Get_Wait_For_Data (LA.Line, Waiter);
Waiter.Wait
(CNF.Cleaner_Client_Header_Timeout (LA.Server.Properties),
Wait_Count);
LA.Server.Slots.Mark_Phase (LA.Line, Client_Header);
if Wait_Count > 0 and then Waiter.Status (2) (Net.Input) then
return True;
end if;
elsif Sock.Check ((Net.Input => True, others => False)) (Net.Input) then
return True;
end if;
LA.Server.Slots.Prepare_Back (LA.Line, Back_OK);
if Back_OK then
HTTP_Acceptors.Give_Back
(LA.Server.Acceptor, Sock, H2_Ref, Success => Back_OK);
if not Back_OK then
AWS.Log.Write
(LA.Server.Error_Log,
"Could not put socket back into acceptor, line"
& LA.Line'Img);
Sock.Shutdown;
end if;
end if;
return False;
end Next_Request_Or_Give_Back;
--------------------------
-- Session_Private_Name --
--------------------------
function Session_Private_Name return String is
begin
return CNF.Session_Private_Name (Server.Get_Current.Config);
end Session_Private_Name;
----------------------
-- Protocol_Handler --
----------------------
procedure Protocol_Handler (LA : in out Line_Attribute_Record) is separate;
procedure Protocol_Handler_V2
(LA : in out Line_Attribute_Record;
Will_Close : out Boolean;
HTTP2_Ref : HTTP2_Context_References.Ref;
Check_Preface : Boolean := True) is separate;
------------------
-- Session_Name --
------------------
function Session_Name return String is
begin
return CNF.Session_Name (Server.Get_Current.Config);
end Session_Name;
---------
-- Set --
---------
procedure Set
(Web_Server : in out HTTP;
Dispatcher : Dispatchers.Handler'Class) is
begin
Dispatchers.Free (Web_Server.New_Dispatcher);
Web_Server.New_Dispatcher :=
new Dispatchers.Handler'Class'
(Dispatchers.Handler'Class (Dispatcher.Clone));
end Set;
---------------
-- Set_Field --
---------------
procedure Set_Field (Id, Value : String) is
Task_Ptr : constant Line_Attribute.Attribute_Handle :=
Line_Attribute.Reference;
begin
AWS.Log.Set_Field (Task_Ptr.Server.Log, Task_Ptr.Log_Data, Id, Value);
end Set_Field;
------------------
-- Set_Security --
------------------
procedure Set_Security
(Web_Server : in out HTTP;
Certificate_Filename : String;
Security_Mode : Net.SSL.Method := Net.SSL.TLS_Server;
Key_Filename : String := "") is
begin
CNF.Set.Certificate (Web_Server.Properties, Certificate_Filename);
if Key_Filename = "" then
CNF.Set.Key (Web_Server.Properties, Certificate_Filename);
else
CNF.Set.Key (Web_Server.Properties, Key_Filename);
end if;
CNF.Set.Security_Mode
(Web_Server.Properties, Net.SSL.Method'Image (Security_Mode));
end Set_Security;
----------------------------
-- Set_Socket_Constructor --
----------------------------
procedure Set_Socket_Constructor
(Web_Server : in out HTTP;
Socket_Constructor : Net.Socket_Constructor) is
begin
HTTP_Acceptors.Set_Socket_Constructor
(Web_Server.Acceptor, Socket_Constructor);
end Set_Socket_Constructor;
--------------------
-- Set_SSL_Config --
--------------------
procedure Set_SSL_Config
(Web_Server : in out HTTP; SSL_Config : Net.SSL.Config) is
begin
Web_Server.SSL_Config := SSL_Config;
if CNF.HTTP2_Activated (Web_Server.Properties) then
Net.SSL.ALPN_Include (Web_Server.SSL_Config, Messages.H2_Token);
end if;
end Set_SSL_Config;
--------------------------------------
-- Set_Unexpected_Exception_Handler --
--------------------------------------
procedure Set_Unexpected_Exception_Handler
(Web_Server : in out HTTP;
Handler : Exceptions.Unexpected_Exception_Handler) is
begin
if Web_Server.Shutdown then
Web_Server.Exception_Handler := Handler;
else
raise Constraint_Error
with "Could not change exception handler on the active server.";
end if;
end Set_Unexpected_Exception_Handler;
--------------
-- Shutdown --
--------------
procedure Shutdown (Web_Server : in out HTTP) is
procedure Unchecked_Free is
new Unchecked_Deallocation (Line_Set, Line_Set_Access);
procedure Unchecked_Free is
new Unchecked_Deallocation (Slots, Slots_Access);
procedure Unchecked_Free is
new Unchecked_Deallocation (Line, Line_Access);
All_Lines_Terminated : Boolean := False;
Slot_State : Slot_Phase := Closed;
Slot_Index : Positive := Positive'Last;
Wait_Counter : Natural := 0;
begin
if Web_Server.Shutdown then
return;
end if;
-- Set the current server status to shutdown. This will ensure than no
-- request will be accepted anymore. All current lines on the
-- Accept_Socket_Serialized queue will return. This leaves a single
-- line to handle. See below.
Web_Server.Shutdown := True;
-- In the queue, waiting for a connection we have a single line waiting.
-- We need to unlock this line properly. Closing the server socket
-- directly is not possible as this line could be waiting on the routine
-- Accept_Socket or poll (see Wait_For implementation). On some OS (AIX
-- for example), trying to close a sockets waiting on a select/poll
-- will lock until the select/poll return or timeout. So the server
-- termination is a bit tricky and requires some attention.
-- Net.Acceptors doing shutdown in the accepting task,
-- Net.Acceptors.Shutdown only sending command into task where the
-- waiting for accept is.
HTTP_Acceptors.Shutdown (Web_Server.Acceptor);
-- Release the slots
for S in 1 .. Web_Server.Slots.N loop
declare
Socket : Socket_Access;
begin
Web_Server.Slots.Get_For_Shutdown (S, Socket);
if Socket /= null then
Net.Shutdown (Socket.all);
Web_Server.Slots.Shutdown_Done (S);
end if;
exception
when others =>
Web_Server.Slots.Shutdown_Done (S);
raise;
end;
end loop;
-- Wait for all lines to be terminated to be able to release associated
-- memory.
while not All_Lines_Terminated loop
All_Lines_Terminated := True;
for K in Web_Server.Lines'Range loop
if not Web_Server.Lines (K)'Terminated then
All_Lines_Terminated := False;
Slot_Index := K;
Slot_State := Web_Server.Slots.Phase (K);
end if;
end loop;
delay 0.5;
Wait_Counter := Wait_Counter + 1;
if Wait_Counter > 30 then
Ada.Text_IO.Put_Line
(Text_IO.Current_Error,
"Can't terminate all lines. Slot" & Positive'Image (Slot_Index)
& " in " & Slot_State'Img & " state.");
exit;
end if;
end loop;
-- Release lines and slots memory
for K in Web_Server.Lines'Range loop
Unchecked_Free (Web_Server.Lines (K));
end loop;
Unchecked_Free (Web_Server.Lines);
Unchecked_Free (Web_Server.Slots);
Dispatchers.Free (Web_Server.Dispatcher);
-- Release the session server if needed
if CNF.Session (Web_Server.Properties) then
Session.Control.Shutdown;
end if;
Services.Transient_Pages.Control.Shutdown;
Net.WebSocket.Registry.Control.Shutdown;
if CNF.Security (Web_Server.Properties) then
Net.SSL.Release (Web_Server.SSL_Config);
end if;
-- Close logs, this ensure that all data will be written to the file
Log.Stop (Web_Server);
Log.Stop_Error (Web_Server);
-- Server removed
Server_Counter.Decrement (Value => Wait_Counter);
if Wait_Counter = 0 then
No_Servers.all;
end if;
end Shutdown;
---------------------
-- Skip_Log_Record --
---------------------
procedure Skip_Log_Record is
begin
Line_Attribute.Reference.Skip_Log := True;
end Skip_Log_Record;
-----------
-- Slots --
-----------
protected body Slots is
----------------------
-- Abort_On_Timeout --
----------------------
procedure Abort_On_Timeout
(Socket : out Socket_Access; Index : in out Positive)
is
use Ada.Calendar;
Now : constant Time := Clock;
function Test_Slot (S : Positive) return Boolean;
---------------
-- Test_Slot --
---------------
function Test_Slot (S : Positive) return Boolean is
begin
if Table (S).Phase = Wait_For_Client then
Table (S).Wait_Breaker.Send ((1 => 0));
elsif Is_Abortable (S) then
Get_For_Shutdown (S, Socket);
if Socket /= null then
Index := S;
return True;
end if;
end if;
return False;
end Test_Slot;
begin
Socket := null;
if Now - Last_Force < 0.5 then
-- Look for force timeout not faster than two times in a second
return;
end if;
Last_Force := Now;
for S in Index + 1 .. Table'Last loop
if Test_Slot (S) then
return;
end if;
end loop;
for S in Table'First .. Index - 1 loop
if Test_Slot (S) then
return;
end if;
end loop;
end Abort_On_Timeout;
------------------------
-- Check_Data_Timeout --
------------------------
procedure Check_Data_Timeout (Index : Positive) is
use Ada.Real_Time;
begin
if Clock - Table (Index).Phase_Time_Stamp
> To_Time_Span (Timeouts (Cleaner, Table (Index).Phase))
then
raise Net.Socket_Error;
end if;
end Check_Data_Timeout;
----------------
-- Free_Slots --
----------------
function Free_Slots return Natural is
begin
return Count;
end Free_Slots;
---------
-- Get --
---------
function Get (Index : Positive) return Slot is
begin
return Table (Index);
end Get;
----------------------
-- Get_For_Shutdown --
----------------------
procedure Get_For_Shutdown
(Index : Positive; Socket : out Socket_Access) is
begin
if Table (Index).Phase not in Closed .. Aborted then
Socket := Table (Index).Sock;
if Socket = null then
Mark_Phase (Index, Aborted);
else
Mark_Phase (Index, In_Shutdown);
Shutdown_Count := Shutdown_Count + 1;
end if;
else
Socket := null;
end if;
end Get_For_Shutdown;
------------------
-- Get_Peername --
------------------
function Get_Peername (Index : Positive) return String is
Socket : constant Socket_Access := Table (Index).Sock;
begin
if Socket = null then
return "";
else
return Net.Peer_Addr (Socket.all);
end if;
end Get_Peername;
----------------
-- Get_Socket --
----------------
function Get_Socket (Index : Positive) return Socket_Access is
begin
return Table (Index).Sock;
end Get_Socket;
---------------------
-- Get_Socket_Info --
---------------------
function Get_Socket_Info (Index : Positive) return Socket_Data is
Socket : constant Socket_Access := Table (Index).Sock;
begin
if Socket = null then
return Socket_Data'
(Peername_Length => 1, Peername => "-", FD => 0);
else
declare
Peername : constant String := Net.Peer_Addr (Socket.all);
begin
return Socket_Data'
(Peername_Length => Peername'Length,
Peername => Peername,
FD => Net.Get_FD (Socket.all));
end;
end if;
end Get_Socket_Info;
-----------------------
-- Get_Wait_For_Data --
-----------------------
procedure Get_Wait_For_Data
(Index : Positive;
Reference : out not null FD_Set_Access)
is
use Ada.Streams;
S : Slot renames Table (Index);
begin
if S.Wait_For_Data.Length = 0 then
S.Wait_Receiver.Socket_Pair (S.Wait_Breaker);
S.Wait_Receiver.Set_Timeout (0.0);
S.Wait_For_Data.Add
(S.Wait_Receiver.Get_FD, (Net.Input => True, others => False));
S.Wait_For_Data.Add
(S.Sock.Get_FD, (Net.Input => True, others => False));
else
while S.Wait_Receiver.Pending > 0 loop
declare
Buffer : Stream_Element_Array (1 .. 8);
Last : Ada.Streams.Stream_Element_Offset;
begin
S.Wait_Receiver.Receive (Buffer, Last);
end;
end loop;
S.Wait_For_Data.Replace (2, S.Sock.Get_FD);
end if;
S.Phase := Wait_For_Client;
Reference := S.Wait_For_Data'Access;
end Get_Wait_For_Data;
-------------------------------------
-- Increment_Slot_Activity_Counter --
-------------------------------------
procedure Increment_Slot_Activity_Counter
(Index : Positive; Free_Slots : out Natural) is
begin
Table (Index).Slot_Activity_Counter :=
Table (Index).Slot_Activity_Counter + 1;
Table (Index).Alive_Counter :=
Table (Index).Alive_Counter + 1;
Free_Slots := Count;
end Increment_Slot_Activity_Counter;
------------------
-- Is_Abortable --
------------------
function Is_Abortable (Index : Positive) return Boolean is
use Real_Time;
Phase : constant Slot_Phase := Table (Index).Phase;
begin
return Phase in Abortable_Phase
and then Clock - Table (Index).Phase_Time_Stamp
> To_Time_Span (Timeouts (Force, Phase));
end Is_Abortable;
----------------
-- Mark_Phase --
----------------
procedure Mark_Phase (Index : Positive; Phase : Slot_Phase) is
Was : constant Slot_Phase := Table (Index).Phase;
Mode : constant array (Boolean) of Timeout_Mode :=
(True => Force, False => Cleaner);
begin
-- Check if the Aborted phase happen after socket operation
-- and before Mark_Phase call.
if Table (Index).Phase in In_Shutdown .. Aborted
and then Phase in Wait_For_Client .. Server_Processing
then
raise Net.Socket_Error;
end if;
pragma Assert
((if Table (Index).Phase = Closed then Table (Index).Sock = null
else True),
Table (Index).Phase'Img & ' ' & Phase'Img
& ' ' & Boolean'Image (Table (Index).Sock = null));
Table (Index).Phase_Time_Stamp := Real_Time.Clock;
Table (Index).Phase := Phase;
if Phase in Data_Phase then
Net.Set_Timeout (Table (Index).Sock.all, Data_Timeouts (Phase));
elsif Phase in Abortable_Phase then
Net.Set_Timeout
(Table (Index).Sock.all, Timeouts (Mode (Count = 0), Phase));
elsif Phase = Closed then
Table (Index).Sock := null;
end if;
end Mark_Phase;
-----------
-- Phase --
-----------
function Phase (Index : Positive) return Slot_Phase is
begin
return Table (Index).Phase;
end Phase;
------------------
-- Prepare_Back --
------------------
procedure Prepare_Back (Index : Positive; Possible : out Boolean) is
begin
Possible := not (Table (Index).Phase in In_Shutdown .. Aborted);
if Possible then
Mark_Phase (Index, Closed);
Table (Index).Sock := null;
end if;
end Prepare_Back;
-------------
-- Release --
-------------
entry Release
(Index : Positive; Shutdown : out Boolean) when Shutdown_Count = 0 is
begin
pragma Assert (Count < N);
-- No more release than it is possible
pragma Assert
((Table (Index).Phase = Closed
and then -- If phase is closed, then Sock must be null
Table (Index).Sock = null)
or else -- or phase is not closed
Table (Index).Phase /= Closed,
Table (Index).Phase'Img
& ' ' & Boolean'Image (Table (Index).Sock = null));
Count := Count + 1;
Shutdown := False;
if Table (Index).Phase /= Closed then
if not Table (Index).Socket_Taken then
if Table (Index).Phase /= Aborted then
-- We have to shutdown socket only if it is not in state:
-- In_Shutdow, Aborted or Closed.
Shutdown := True;
else
Net.Free (Table (Index).Sock);
end if;
else
Table (Index).Socket_Taken := False;
end if;
Mark_Phase (Index, Closed);
Table (Index).Sock := null;
end if;
end Release;
---------
-- Set --
---------
procedure Set (Socket : not null Net.Socket_Access; Index : Positive) is
begin
pragma Assert (Count > 0);
Table (Index).Phase := Client_Header;
Table (Index).Sock := Socket;
Table (Index).Alive_Counter := 0;
Table (Index).Alive_Time_Stamp := Ada.Calendar.Clock;
Table (Index).Activity_Counter := Table (Index).Activity_Counter + 1;
Count := Count - 1;
end Set;
------------------
-- Set_Timeouts --
------------------
procedure Set_Timeouts
(Phase_Timeouts : Timeouts_Array;
Data_Timeouts : Data_Timeouts_Array) is
begin
Timeouts := Phase_Timeouts;
Slots.Data_Timeouts := Set_Timeouts.Data_Timeouts;
end Set_Timeouts;
-------------------
-- Shutdown_Done --
-------------------
procedure Shutdown_Done (Index : Positive) is
begin
if Table (Index).Phase = In_Shutdown then
Mark_Phase (Index, Aborted);
Shutdown_Count := Shutdown_Count - 1;
end if;
end Shutdown_Done;
------------------
-- Socket_Taken --
------------------
procedure Socket_Taken (Index : Positive) is
begin
Table (Index).Socket_Taken := True;
Table (Index).Sock := null;
end Socket_Taken;
end Slots;
------------------
-- Socket_Taken --
------------------
procedure Socket_Taken is
TA : constant Line_Attribute.Attribute_Handle :=
Line_Attribute.Reference;
begin
TA.Server.Slots.Socket_Taken (TA.Line);
end Socket_Taken;
----------------
-- SSL_Config --
----------------
function SSL_Config
(Web_Server : in out HTTP) return not null access Net.SSL.Config is
begin
return Web_Server.SSL_Config'Unchecked_Access;
end SSL_Config;
-----------
-- Start --
-----------
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) is
begin
CNF.Set.Server_Name (Web_Server.Properties, Name);
CNF.Set.Admin_URI (Web_Server.Properties, Admin_URI);
CNF.Set.Server_Port (Web_Server.Properties, Port);
CNF.Set.Security (Web_Server.Properties, Security);
CNF.Set.Session (Web_Server.Properties, Session);
CNF.Set.Upload_Directory (Web_Server.Properties, Upload_Directory);
CNF.Set.Max_Connection (Web_Server.Properties, Max_Connection);
CNF.Set.Line_Stack_Size (Web_Server.Properties, Line_Stack_Size);
CNF.Set.Case_Sensitive_Parameters
(Web_Server.Properties, Case_Sensitive_Parameters);
Start (Web_Server, Dispatchers.Callback.Create (Callback));
end Start;
-----------
-- Start --
-----------
procedure Start
(Web_Server : in out HTTP;
Callback : Response.Callback;
Config : AWS.Config.Object) is
begin
Web_Server.Properties := Config;
Start (Web_Server, Dispatchers.Callback.Create (Callback));
end Start;
-----------
-- Start --
-----------
procedure Start
(Web_Server : in out HTTP;
Dispatcher : Dispatchers.Handler'Class;
Config : AWS.Config.Object) is
begin
Web_Server.Properties := Config;
Start (Web_Server, Dispatcher);
end Start;
-----------
-- Start --
-----------
procedure Start
(Web_Server : in out HTTP;
Dispatcher : Dispatchers.Handler'Class)
is
use type Net.SSL.Config;
Max_Connection : constant Positive :=
CNF.Max_Connection (Web_Server.Properties);
SC : Natural;
function Security_Mode return Net.SSL.Method;
-- Returns the server security mode, returns the default method if the
-- current one is not recognized.
-------------------
-- Security_Mode --
-------------------
function Security_Mode return Net.SSL.Method is
begin
return Net.SSL.Method'Value
(CNF.Security_Mode (Web_Server.Properties));
exception
when Constraint_Error =>
return Net.SSL.Method'Value (Default.Security_Mode);
end Security_Mode;
begin
-- If it is an SSL connection, initialize the SSL library
if CNF.Security (Web_Server.Properties) then
if Web_Server.SSL_Config = Net.SSL.Null_Config then
Net.SSL.Initialize
(Web_Server.SSL_Config,
CNF.Certificate (Web_Server.Properties),
Security_Mode,
Priorities =>
CNF.Cipher_Priorities (Web_Server.Properties),
Ticket_Support =>
CNF.TLS_Ticket_Support (Web_Server.Properties),
Key_Filename =>
CNF.Key (Web_Server.Properties),
Exchange_Certificate =>
CNF.Exchange_Certificate (Web_Server.Properties),
Certificate_Required =>
CNF.Certificate_Required (Web_Server.Properties),
Trusted_CA_Filename =>
CNF.Trusted_CA (Web_Server.Properties),
CRL_Filename =>
CNF.CRL_File (Web_Server.Properties),
Session_Cache_Size =>
CNF.SSL_Session_Cache_Size (Web_Server.Properties));
end if;
if CNF.HTTP2_Activated (Web_Server.Properties) then
Net.SSL.ALPN_Include (Web_Server.SSL_Config, Messages.H2_Token);
end if;
end if;
-- Create the Web Server socket set
HTTP_Acceptors.Listen
(Acceptor => Web_Server.Acceptor,
Host => CNF.Server_Host (Web_Server.Properties),
Port => CNF.Server_Port (Web_Server.Properties),
Queue_Size => CNF.Accept_Queue_Size (Web_Server.Properties),
Family =>
Net.Family_Type'Value (CNF.Protocol_Family (Web_Server.Properties)),
Timeout =>
CNF.Cleaner_Wait_For_Client_Timeout (Web_Server.Properties),
First_Timeout =>
CNF.Cleaner_Client_Header_Timeout (Web_Server.Properties),
Force_Timeout =>
CNF.Force_Wait_For_Client_Timeout (Web_Server.Properties),
Force_First_Timeout =>
CNF.Force_Client_Header_Timeout (Web_Server.Properties),
Force_Length =>
CNF.Keep_Alive_Force_Limit (Web_Server.Properties),
Close_Length =>
CNF.Keep_Alive_Close_Limit (Web_Server.Properties),
Reuse_Address => CNF.Reuse_Address (Web_Server.Properties),
IPv6_Only => CNF.IPv6_Only (Web_Server.Properties));
-- If Close_On_Exec is set
if CNF.Close_On_Exec (Web_Server.Properties) then
Net.Set_Close_On_Exec
(HTTP_Acceptors.Server_Socket (Web_Server.Acceptor));
end if;
-- Clone main dispatcher
Web_Server.Dispatcher :=
new Dispatchers.Handler'Class'
(Dispatchers.Handler'Class (Dispatcher.Clone));
-- Initialize slots
Web_Server.Slots := new Slots (Max_Connection);
-- Set timeouts
Web_Server.Slots.Set_Timeouts
((Cleaner => -- Timeouts for Line_Cleaner
(Wait_For_Client =>
CNF.Cleaner_Wait_For_Client_Timeout (Web_Server.Properties),
Client_Header =>
CNF.Cleaner_Client_Header_Timeout (Web_Server.Properties),
Client_Data =>
CNF.Cleaner_Client_Data_Timeout (Web_Server.Properties),
Server_Response =>
CNF.Cleaner_Server_Response_Timeout (Web_Server.Properties)),
Force => -- Force timeouts used when there is no free slot
(Wait_For_Client =>
CNF.Force_Wait_For_Client_Timeout (Web_Server.Properties),
Client_Header =>
CNF.Force_Client_Header_Timeout (Web_Server.Properties),
Client_Data =>
CNF.Force_Client_Data_Timeout (Web_Server.Properties),
Server_Response =>
CNF.Force_Server_Response_Timeout (Web_Server.Properties))),
(Client_Data =>
CNF.Receive_Timeout (Web_Server.Properties),
Server_Response =>
CNF.Send_Timeout (Web_Server.Properties)));
-- Started time
Web_Server.Start_Time := Calendar.Clock;
-- Initialize the connection lines
Web_Server.Lines := new Line_Set'
(1 .. Max_Connection => new Line
(Priority => CNF.Server_Priority (Web_Server.Properties),
Stack_Size => CNF.Line_Stack_Size (Web_Server.Properties)));
-- Set Shutdown to False here since it must be done before starting the
-- lines.
Web_Server.Shutdown := False;
-- Start each connection lines
for I in 1 .. Max_Connection loop
Web_Server.Lines (I).Start (Web_Server, I);
end loop;
-- Initialize session server
if CNF.Session (Web_Server.Properties) then
AWS.Session.Control.Start
(Session_Check_Interval => CNF.Session_Cleanup_Interval,
Session_Lifetime => CNF.Session_Lifetime);
end if;
-- Initialize transient service
Services.Transient_Pages.Control.Register
(Transient_Check_Interval => CNF.Transient_Cleanup_Interval);
Server_Counter.Increment (Value => SC);
if SC = 1 then
First_Server.all;
end if;
-- Activate log if requested
if CNF.Log_Activated (Web_Server.Properties) then
Log.Start
(Web_Server,
Split_Mode => AWS.Log.Split_Mode'Value
(CNF.Log_Split_Mode (Web_Server.Properties)));
end if;
if CNF.Error_Log_Activated (Web_Server.Properties) then
Log.Start_Error
(Web_Server,
Split_Mode => AWS.Log.Split_Mode'Value
(CNF.Error_Log_Split_Mode (Web_Server.Properties)));
end if;
end Start;
----------
-- Wait --
----------
procedure Wait (Mode : Termination := No_Server) is
begin
case Mode is
when No_Server =>
Server_Counter.Zero;
when Q_Key_Pressed =>
declare
K : Character;
begin
loop
Text_IO.Get_Immediate (K);
exit when K = 'q' or else K = 'Q';
end loop;
end;
when Forever =>
loop
delay Duration'Last;
end loop;
end case;
end Wait;
end AWS.Server;