------------------------------------------------------------------------------
-- Ada Web Server --
-- --
-- Copyright (C) 2005-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 --
-- . --
-- --
-- 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.Characters.Handling;
with Ada.Directories;
with Ada.Streams.Stream_IO;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with GNAT.MD5;
with GNAT.OS_Lib;
with GNAT.Regexp;
with AWS.Digest;
with AWS.Dispatchers;
with AWS.Headers.Values;
with AWS.Hotplug;
with AWS.HTTP2;
with AWS.Log;
with AWS.Messages;
with AWS.MIME;
with AWS.Net;
with AWS.Net.Buffered;
with AWS.Net.WebSocket.Handshake_Error;
with AWS.Net.WebSocket.Protocol.Draft76;
with AWS.Net.WebSocket.Protocol.RFC6455;
with AWS.Net.WebSocket.Registry.Utils;
with AWS.Parameters;
with AWS.Response.Set;
with AWS.Server.Get_Status;
with AWS.Session;
with AWS.Status.Set;
with AWS.Templates;
with AWS.Translator;
with AWS.URL;
with AWS.Utils;
package body AWS.Server.HTTP_Utils is
use Ada.Strings;
use Ada.Strings.Unbounded;
protected File_Upload_UID is
procedure Get (ID : out Natural);
-- returns a UID for file upload. This is to ensure that files
-- coming from clients will always have different name.
private
UID : Natural := 0;
end File_Upload_UID;
----------------------
-- Answer_To_Client --
----------------------
procedure Answer_To_Client
(HTTP_Server : in out AWS.Server.HTTP;
Line_Index : Positive;
C_Stat : in out AWS.Status.Data;
Socket_Taken : in out Boolean;
Will_Close : in out Boolean)
is
use type Messages.Status_Code;
Answer : Response.Data := Build_Answer (HTTP_Server, C_Stat);
Need_Purge : Boolean := False;
begin
if Response.Is_Continue (Answer)
and then not Status.Is_Body_Uploaded (C_Stat)
then
-- Upload message body and call user dispatcher again
Get_Message_Data
(HTTP_Server, Line_Index, C_Stat,
Expect_100 => Status.Expect (C_Stat) = Messages.S100_Continue);
Answer := Call_For_Dispatcher (HTTP_Server, C_Stat);
elsif HTTP_Server.Slots.Phase (Line_Index) = Client_Data then
-- User callback did not read clients message body. If client do not
-- support 100 (Continue) response, we have to close
-- socket to discard pending client data.
Need_Purge := Status.Expect (C_Stat) /= Messages.S100_Continue;
if not Will_Close then
Will_Close := Need_Purge;
end if;
if Response.Status_Code (Answer) < Messages.S300 then
Log.Write
(HTTP_Server.Error_Log,
C_Stat,
"User does not upload server data but return status "
& Messages.Image (Response.Status_Code (Answer)));
end if;
end if;
Send (Answer, HTTP_Server, Line_Index, C_Stat, Socket_Taken, Will_Close);
if Need_Purge then
-- User callback did not read client data and client does not support
-- 100 (Continue) response. We need clear socket input buffers to be
-- able to close socket gracefully.
declare
use Ada.Real_Time;
Socket : constant Net.Socket_Type'Class := Status.Socket (C_Stat);
Buffer : Stream_Element_Array (1 .. 4096);
Last : Stream_Element_Offset;
Length : Stream_Element_Count := Status.Content_Length (C_Stat);
Stamp : constant Time := Clock;
Span : constant Time_Span :=
To_Time_Span
(CNF.Receive_Timeout (HTTP_Server.Properties));
-- To do not spend too much time on wrong working clients
Agent : constant String := Status.User_Agent (C_Stat);
Fully : constant Boolean :=
Fixed.Index (Agent, "Firefox/") > 0
or else Fixed.Index (Agent, "konqueror/") > 0;
-- JavaScript engine of some browsers does not read the server
-- responce until successfully send the whole message body.
-- So we have to read the whole body to let them chance to read
-- the server answer.
-- Tested for Firefox/43.0 and konqueror/4.14.9.
-- Does not need this trick:
-- OPR/32.0.1948.69 - Opera
-- Midori/0.5
-- Chrome/47.0.2526.106
begin
while (Fully and then Length > 0 and then Stamp - Clock <= Span)
or else Socket.Pending > 0
loop
Socket.Receive (Buffer, Last);
Length := Length - Stream_Element_Count (Last);
end loop;
end;
end if;
end Answer_To_Client;
------------------
-- Build_Answer --
------------------
function Build_Answer
(HTTP_Server : in out AWS.Server.HTTP;
C_Stat : in out AWS.Status.Data) return Response.Data
is
use type Status.Protocol_State;
procedure Create_Session;
-- Create a session if needed
function Status_Page (URI : String) return Response.Data;
-- Handle status page
function Is_Ignored (Answer : Response.Data) return Boolean;
-- Returns True if the Answer is to be ignored based on If-Match or
-- If-Not-Match and ETag if any.
Admin_URI : constant String := CNF.Admin_URI (HTTP_Server.Properties);
--------------------
-- Create_Session --
--------------------
procedure Create_Session is
begin
if CNF.Session (HTTP_Server.Properties)
and then (not Status.Has_Session (C_Stat)
or else not Session.Exist (Status.Session (C_Stat)))
then
-- Generate the session ID
Status.Set.Session (C_Stat);
end if;
end Create_Session;
----------------
-- Is_Ignored --
----------------
function Is_Ignored (Answer : Response.Data) return Boolean is
begin
if Response.Has_Header (Answer, Messages.ETag_Token) then
declare
ETag : constant String :=
Response.Header (Answer, Messages.ETag_Token);
H : constant Headers.List := Status.Header (C_Stat);
begin
-- The request must be ignored if the header If_Match is
-- found and the ETag does not correspond or if the header
-- If-None-Match is found and the ETag correspond.
return (H.Exist (Messages.If_Match_Token)
and then Strings.Fixed.Index
(H.Get_Values (Messages.If_Match_Token), ETag) = 0)
or else
(H.Exist (Messages.If_None_Match_Token)
and then Strings.Fixed.Index
(H.Get_Values (Messages.If_None_Match_Token),
ETag) /= 0);
end;
else
return False;
end if;
end Is_Ignored;
-----------------
-- Status_Page --
-----------------
function Status_Page (URI : String) return Response.Data is
use type AWS.Status.Authorization_Type;
Answer : Response.Data;
Username : constant String :=
AWS.Status.Authorization_Name (C_Stat);
Password : constant String :=
AWS.Status.Authorization_Password (C_Stat);
Method : constant AWS.Status.Authorization_Type :=
AWS.Status.Authorization_Mode (C_Stat);
procedure Answer_File (File_Name : String);
-- Assign File to Answer response data
-----------------
-- Answer_File --
-----------------
procedure Answer_File (File_Name : String) is
begin
Answer := Response.File
(Content_Type => MIME.Content_Type (File_Name),
Filename => File_Name);
end Answer_File;
begin
-- First check for authentification
if Method = AWS.Status.Digest then
if AWS.Status.Authorization_Response (C_Stat)
= GNAT.MD5.Digest
(CNF.Admin_Password (HTTP_Server.Properties)
& AWS.Status.Authorization_Tail (C_Stat))
then
if not AWS.Digest.Check_Nonce
(Status.Authorization_Nonce (C_Stat))
then
return AWS.Response.Authenticate
(CNF.Admin_Realm (HTTP_Server.Properties),
AWS.Response.Digest,
Stale => True);
end if;
else
return AWS.Response.Authenticate
(CNF.Admin_Realm (HTTP_Server.Properties),
AWS.Response.Digest);
end if;
elsif (Method = AWS.Status.Basic
and then CNF.Admin_Password (HTTP_Server.Properties)
/= GNAT.MD5.Digest
(Username
& ':' & CNF.Admin_Realm (HTTP_Server.Properties)
& ':' & Password))
or else Method = AWS.Status.None or else Password = ""
then
return Response.Authenticate
(CNF.Admin_Realm (HTTP_Server.Properties), Response.Any);
end if;
if URI = Admin_URI then
-- Status page
begin
Answer := Response.Build
(Content_Type => MIME.Text_HTML,
Message_Body => Get_Status (HTTP_Server));
exception
when Templates.Template_Error =>
Answer := Response.Build
(Content_Type => MIME.Text_HTML,
Message_Body =>
"Status template error. Please check "
& "that '" & CNF.Status_Page (HTTP_Server.Properties)
& "' file is valid.");
end;
elsif URI = Admin_URI & "-logo" then
-- Status page logo
Answer_File (CNF.Logo_Image (HTTP_Server.Properties));
elsif URI = Admin_URI & "-uparr" then
-- Status page hotplug up-arrow
Answer_File (CNF.Up_Image (HTTP_Server.Properties));
elsif URI = Admin_URI & "-downarr" then
-- Status page hotplug down-arrow
Answer_File (CNF.Down_Image (HTTP_Server.Properties));
elsif URI = Admin_URI & "-HPup" then
-- Status page hotplug up message
Hotplug.Move_Up
(HTTP_Server.Filters,
Positive'Value (Status.Parameter (C_Stat, "N")));
Answer := Response.URL (Admin_URI);
elsif URI = Admin_URI & "-HPdown" then
-- Status page hotplug down message
Hotplug.Move_Down
(HTTP_Server.Filters,
Positive'Value (Status.Parameter (C_Stat, "N")));
Answer := Response.URL (Admin_URI);
else
Answer := Response.Build
(Content_Type => MIME.Text_HTML,
Message_Body =>
"Invalid use of reserved status URI prefix: " & Admin_URI);
end if;
return Answer;
end Status_Page;
URL : constant AWS.URL.Object := AWS.Status.URI (C_Stat);
URI : constant String := AWS.URL.Abs_Path (URL);
Answer : Response.Data;
begin
-- Check if the status page, status page logo or status page images
-- are requested. These are AWS internal data that should not be
-- handled by AWS users.
-- AWS Internal status page handling
if Admin_URI'Length > 0
and then
URI'Length >= Admin_URI'Length
and then
URI (URI'First .. URI'First + Admin_URI'Length - 1) = Admin_URI
then
Answer := Status_Page (URI);
-- Check if the URL is trying to reference resource above Web root
-- directory.
elsif CNF.Check_URL_Validity (HTTP_Server.Properties)
and then not AWS.URL.Is_Valid (URL)
then
-- 403 status code "Forbidden"
Answer := Response.Build
(Status_Code => Messages.S403,
Content_Type => "text/plain",
Message_Body => "Request " & URI & ASCII.LF
& " trying to reach resource above the Web root directory.");
-- Check if we have a websockets request
elsif Headers.Values.Unnamed_Value_Exists
(Status.Connection (C_Stat), "upgrade", Case_Sensitive => False)
and then
Headers.Values.Unnamed_Value_Exists
(Status.Upgrade (C_Stat), "websocket", Case_Sensitive => False)
then
Answer := Response.WebSocket;
else
-- Otherwise, check if a session needs to be created
Create_Session;
-- and get answer from client callback
declare
use type Dispatchers.Handler_Class_Access;
Found : Boolean;
begin
-- Check the hotplug filters
Hotplug.Apply (HTTP_Server.Filters, C_Stat, Found, Answer);
-- If no one applied, run the user callback
if not Found then
if HTTP_Server.New_Dispatcher /= null then
HTTP_Server.Dispatcher_Sem.Write;
Dispatchers.Free (HTTP_Server.Dispatcher);
HTTP_Server.Dispatcher := HTTP_Server.New_Dispatcher;
HTTP_Server.New_Dispatcher := null;
HTTP_Server.Dispatcher_Sem.Release_Write;
end if;
Answer := Call_For_Dispatcher (HTTP_Server, C_Stat);
end if;
-- Switching protocol if needed and server has HTTP/2
-- activated.
if Status.Protocol (C_Stat) = Status.Upgrade_To_H2C
and then AWS.Config.HTTP2_Activated (HTTP_Server.Config)
then
Response.Set.Status_Code (Answer, Messages.S101);
Response.Set.Add_Header
(Answer, Messages.Connection_Token, Messages.Upgrade_Token);
Response.Set.Add_Header
(Answer, Messages.Upgrade_Token, Messages.H2C_Token);
end if;
-- Then check if the answer is to be ignored as per
-- If-Match/If-None-Match and ETag values.
if Is_Ignored (Answer) then
Answer := Response.Acknowledge (Messages.S304);
end if;
end;
AWS.Status.Set.Delete_Idle_Session (C_Stat);
end if;
return Answer;
end Build_Answer;
-------------------------
-- Call_For_Dispatcher --
-------------------------
function Call_For_Dispatcher
(HTTP_Server : in out AWS.Server.HTTP;
C_Stat : AWS.Status.Data) return Response.Data is
begin
HTTP_Server.Dispatcher_Sem.Read;
-- Be sure to always release the read semaphore
return Answer : constant Response.Data :=
Dispatchers.Dispatch (HTTP_Server.Dispatcher.all, C_Stat)
do
HTTP_Server.Dispatcher_Sem.Release_Read;
end return;
exception
when others =>
HTTP_Server.Dispatcher_Sem.Release_Read;
raise;
end Call_For_Dispatcher;
---------------------
-- File_Upload_UID --
---------------------
protected body File_Upload_UID is
---------
-- Get --
---------
procedure Get (ID : out Natural) is
begin
ID := UID;
UID := UID + 1;
end Get;
end File_Upload_UID;
-------------------------
-- Multipart_Message_G --
-------------------------
package body Multipart_Message_G is
procedure Read is new Headers.Read_G (Get_Line);
-- Read header using generic Get_Line
-----------------
-- File_Upload --
-----------------
procedure File_Upload
(C_Stat : in out Status.Data;
Attachments : in out AWS.Attachments.List;
Start_Boundary, End_Boundary : String;
Parse_Boundary : Boolean)
is
procedure Target_Filename
(Filename : String;
Server_Filename, Decoded_Server_Filename : out Unbounded_String);
-- Returns the full path names (std and decoded) for the
-- file as stored on the server side.
---------------------
-- Target_Filename --
---------------------
procedure Target_Filename
(Filename : String;
Server_Filename, Decoded_Server_Filename : out Unbounded_String)
is
Upload_Path : constant String :=
CNF.Upload_Directory (Server_Config);
File_Upload_UID : constant String := Get_File_Upload_UID;
begin
Server_Filename := To_Unbounded_String
(Upload_Path & File_Upload_UID & '.' & Filename);
Decoded_Server_Filename := To_Unbounded_String
(Upload_Path & File_Upload_UID & '.' & URL.Decode (Filename));
end Target_Filename;
Name : Unbounded_String;
Filename : Unbounded_String;
Server_Filename : Unbounded_String;
Decoded_Server_Filename : Unbounded_String;
Is_File_Upload : Boolean;
Headers : AWS.Headers.List;
End_Found : Boolean := False;
-- Set to true when the end-boundary has been found
begin
-- Reach the boundary
if Parse_Boundary then
loop
declare
Data : constant String := Get_Line;
begin
exit when Data = Start_Boundary;
if Data = End_Boundary then
-- This is the end of the multipart data
return;
end if;
end;
end loop;
end if;
-- Read header
Read (Headers);
if AWS.Headers.Get_Values
(Headers, Messages.Content_Type_Token) = MIME.Application_Form_Data
then
-- This chunk is the form parameter
Read_Body (C_Stat, Boundary => Start_Boundary);
-- Skip CRLF after boundary
declare
Data : constant String := Get_Line with Unreferenced;
begin
null;
end;
File_Upload
(C_Stat, Attachments, Start_Boundary, End_Boundary, False);
Status.Set.Parameters_From_Body
(C_Stat, (if Is_H2 then Start_Boundary else ""));
else
-- Read file upload parameters
declare
Data : constant String :=
AWS.Headers.Get_Values
(Headers, Messages.Content_Disposition_Token);
L_Name : constant String :=
AWS.Headers.Values.Search (Data, "name");
L_Filename : constant String :=
URL.Decode
(AWS.Headers.Values.Search (Data, "filename"));
-- Get the simple name as we do not want to expose the client
-- full pathname to the user's callback. Microsoft Internet
-- Explorer sends the full pathname, Firefox only send the
-- simple name.
begin
Is_File_Upload := (L_Filename /= "");
Name := To_Unbounded_String (L_Name);
if Is_File_Upload then
Filename := To_Unbounded_String
(URL.Encode (Directories.Simple_Name (L_Filename)));
end if;
end;
-- Read file/field data
if Is_File_Upload then
-- This part of the multipart message contains file data
if CNF.Upload_Directory (Server_Config) = "" then
raise Constraint_Error
with "File upload not supported by server "
& CNF.Server_Name (Server_Config);
end if;
-- Set Server_Filename, the name of the file in the local file
-- sytstem.
Target_Filename
(To_String (Filename),
Server_Filename, Decoded_Server_Filename);
if To_String (Filename) /= "" then
-- First value is the unique name on the server side
Status.Set.Add_Parameter
(C_Stat, To_String (Name), To_String (Server_Filename));
-- Status.Set.Add_Parameter does not decode values
-- Second value is the original name as found on the client
-- side.
Status.Set.Add_Parameter
(C_Stat, To_String (Name), To_String (Filename));
-- Status.Set.Add_Parameter does not decode values
-- Read file data, set End_Found if the end-boundary
-- signature has been read.
Get_File_Data
(C_Stat,
Attachments,
To_String (Decoded_Server_Filename),
To_String (Filename),
Start_Boundary,
File_Upload,
Headers,
End_Found);
-- Create an attachment entry, this will ensure that the
-- physical file will be removed. It will also be possible
-- to work with the attachment instead of the parameters set
-- above.
AWS.Attachments.Add
(Attachments,
Filename => To_String (Decoded_Server_Filename),
Name => To_String (Filename),
Content_Id => To_String (Name),
Headers => Headers);
Status.Set.Attachments (C_Stat, Attachments);
if not End_Found then
File_Upload
(C_Stat, Attachments,
Start_Boundary, End_Boundary, False);
end if;
else
-- There is no file for this multipart, user did not enter
-- something in the field.
File_Upload
(C_Stat, Attachments, Start_Boundary, End_Boundary, True);
end if;
else
-- This part of the multipart message contains field values
declare
Value : Unbounded_String;
begin
loop
declare
L : constant String := Get_Line;
begin
End_Found := (L = End_Boundary);
exit when End_Found or else L = Start_Boundary;
-- Append this line to the value
Utils.Append_With_Sep
(Value, L, Sep => ASCII.CR & ASCII.LF);
end;
end loop;
Status.Set.Add_Parameter
(C_Stat, Name, Value, Decode => False);
-- Do not decode values for multipart/form-data
end;
if not End_Found then
File_Upload
(C_Stat, Attachments, Start_Boundary, End_Boundary, False);
end if;
end if;
end if;
end File_Upload;
-------------------
-- Get_File_Data --
-------------------
procedure Get_File_Data
(C_Stat : in out Status.Data;
Attachments : in out AWS.Attachments.List;
Server_Filename : String;
Filename : String;
Start_Boundary : String;
Mode : Message_Mode;
Headers : AWS.Headers.List;
End_Found : out Boolean)
is
type Error_State is (No_Error, Name_Error, Device_Error);
-- This state is to monitor the file upload process. If we receice
-- Name_Error or Device_Error while writing data on disk we need to
-- continue reading all data from the socket if we want to be able
-- to send back an error message.
function Check_EOF return Boolean;
-- Returns True if we have reach the end of file data
procedure Write
(Buffer : Streams.Stream_Element_Array; Trim : Boolean) with Inline;
-- Write buffer to the file, handle the Device_Error exception
File : Streams.Stream_IO.File_Type;
Buffer : Streams.Stream_Element_Array (1 .. 4 * 1_024);
Index : Streams.Stream_Element_Offset := Buffer'First;
Data : Streams.Stream_Element_Array (1 .. 1);
Data2 : Streams.Stream_Element_Array (1 .. 2);
Error : Error_State := No_Error;
---------------
-- Check_EOF --
---------------
function Check_EOF return Boolean is
Signature : constant Streams.Stream_Element_Array :=
(1 => 13, 2 => 10)
& Translator.To_Stream_Element_Array
(Start_Boundary);
Buffer : Streams.Stream_Element_Array (1 .. Signature'Length);
Index : Streams.Stream_Element_Offset := Buffer'First;
procedure Write_Data;
-- Put buffer data into the main buffer (Get_Data.Buffer). If
-- the main buffer is not big enough, it will write the buffer
-- into the file before.
----------------
-- Write_Data --
----------------
procedure Write_Data is
begin
if Error /= No_Error then
return;
end if;
if Get_File_Data.Buffer'Last
< Get_File_Data.Index + Index - 1
then
Write (Get_File_Data.Buffer
(Get_File_Data.Buffer'First
.. Get_File_Data.Index - 1), False);
Get_File_Data.Index := Get_File_Data.Buffer'First;
end if;
Get_File_Data.Buffer
(Get_File_Data.Index .. Get_File_Data.Index + Index - 2) :=
Buffer (Buffer'First .. Index - 1);
Get_File_Data.Index := Get_File_Data.Index + Index - 1;
end Write_Data;
begin -- Check_EOF
Buffer (Index) := 13;
Index := Index + 1;
loop
Read (Data);
if Data (1) = 13 then
Write_Data;
return False;
end if;
Buffer (Index) := Data (1);
if Index = Buffer'Last then
if Buffer = Signature then
return True;
else
Write_Data;
return False;
end if;
end if;
Index := Index + 1;
end loop;
end Check_EOF;
-----------
-- Write --
-----------
procedure Write
(Buffer : Streams.Stream_Element_Array; Trim : Boolean) is
begin
if Error = No_Error then
if Mode in Attachment .. File_Upload then
Streams.Stream_IO.Write (File, Buffer);
else
-- This is the root part of an MIME attachment, append the
-- data to the status record.
Status.Set.Append_Body (C_Stat, Buffer, Trim);
end if;
end if;
exception
when Text_IO.Device_Error =>
Error := Device_Error;
end Write;
begin
begin
if Mode in Attachment .. File_Upload then
Streams.Stream_IO.Create
(File, Streams.Stream_IO.Out_File, Server_Filename);
end if;
exception
when Text_IO.Name_Error =>
Error := Name_Error;
end;
Read_File : loop
Read (Data);
while Data (1) = 13 loop
exit Read_File when Check_EOF;
end loop;
Buffer (Index) := Data (1);
Index := Index + 1;
if Index > Buffer'Last then
Write (Buffer, False);
Index := Buffer'First;
Check_Data_Timeout;
end if;
end loop Read_File;
if Index /= Buffer'First then
Write (Buffer (Buffer'First .. Index - 1), True);
end if;
if Error = No_Error then
case Mode is
when Root_Attachment =>
null;
when Attachment =>
Streams.Stream_IO.Close (File);
AWS.Attachments.Add
(Attachments, Server_Filename, Headers, Filename);
when File_Upload =>
Streams.Stream_IO.Close (File);
end case;
end if;
-- Check for end-boundary, at this point we have at least two
-- chars. Either the terminating "--" or CR+LF.
Read (Data2);
if Data2 (2) = 10 then
-- We have CR+LF, it is a start-boundary
End_Found := False;
else
-- We have read the "--", read line terminator. This is the
-- end-boundary.
End_Found := True;
Read (Data2);
end if;
if Error = Name_Error then
-- We can't create the file, add a clear exception message
raise HTTP_Utils.Name_Error
with "Cannot create file " & Server_Filename;
elsif Error = Device_Error then
-- We can't write to the file, there is probably no space left
-- on devide.
raise HTTP_Utils.Device_Error
with "No space left on device while writing " & Server_Filename;
end if;
end Get_File_Data;
-------------------------
-- Get_File_Upload_UID --
-------------------------
function Get_File_Upload_UID return String is
use GNAT;
Pid : constant Natural := Integer'Max
(0, OS_Lib.Pid_To_Integer (OS_Lib.Current_Process_Id));
-- On OS where Current_Process_Id is not support -1 is returned. We
-- ensure that in this case the Pid is set to 0 in this case.
UID : Natural;
begin
File_Upload_UID.Get (UID);
return Utils.Image (Pid) & "-" & Utils.Image (UID);
end Get_File_Upload_UID;
-----------------------
-- Store_Attachments --
-----------------------
procedure Store_Attachments
(C_Stat : in out Status.Data;
Attachments : in out AWS.Attachments.List;
Start_Boundary, End_Boundary : String;
Parse_Boundary : Boolean;
Multipart_Boundary : String;
Root_Part_CID : String)
is
function Attachment_Filename (Extension : String) return String;
-- Returns the full path name for the file as stored on the
-- server side.
-------------------------
-- Attachment_Filename --
-------------------------
function Attachment_Filename (Extension : String) return String is
Upload_Path : constant String :=
CNF.Upload_Directory (Server_Config);
begin
if Extension = "" then
return Upload_Path & Get_File_Upload_UID;
else
return Upload_Path & Get_File_Upload_UID & '.' & Extension;
end if;
end Attachment_Filename;
Server_Filename : Unbounded_String;
Content_Id : Unbounded_String;
Headers : AWS.Headers.List;
End_Found : Boolean := False;
-- Set to true when the end-boundary has been found
begin
-- Reach the boundary
if Parse_Boundary then
loop
declare
Data : constant String := Get_Line;
begin
exit when Data = Start_Boundary;
if Data = End_Boundary then
-- This is the end of the multipart data
return;
end if;
end;
end loop;
end if;
-- Read header
Read (Headers);
if AWS.Headers.Get_Values
(Headers, Messages.Content_Type_Token) = MIME.Application_Form_Data
then
-- This chunk is the form parameter
Read_Body (C_Stat, Boundary => "--" & Multipart_Boundary);
-- Skip CRLF after boundary
declare
Data : constant String := Get_Line with Unreferenced;
begin
null;
end;
Store_Attachments
(C_Stat, Attachments,
Start_Boundary, End_Boundary, False,
Multipart_Boundary, Root_Part_CID);
-- In HTTP/2 the whole message is read with the multipart header
-- for the main form data.
Status.Set.Parameters_From_Body
(C_Stat, (if Is_H2 then Start_Boundary else ""));
else
Content_Id := To_Unbounded_String
(AWS.Headers.Get (Headers, Messages.Content_Id_Token));
-- Read file/field data
if Content_Id = Root_Part_CID then
Get_File_Data
(C_Stat, Attachments,
"", "", Start_Boundary, Root_Attachment, Headers, End_Found);
else
Server_Filename := To_Unbounded_String
(Attachment_Filename
(AWS.MIME.Extension
(AWS.Headers.Values.Get_Unnamed_Value
(AWS.Headers.Get
(Headers, Messages.Content_Type_Token)))));
Get_File_Data
(C_Stat, Attachments,
To_String (Server_Filename), To_String (Server_Filename),
Start_Boundary, Attachment, Headers, End_Found);
end if;
-- More attachments ?
if End_Found then
AWS.Status.Set.Attachments (C_Stat, Attachments);
else
Store_Attachments
(C_Stat, Attachments,
Start_Boundary, End_Boundary, False,
Multipart_Boundary, Root_Part_CID);
end if;
end if;
end Store_Attachments;
end Multipart_Message_G;
----------------------
-- Get_Message_Data --
----------------------
procedure Get_Message_Data
(HTTP_Server : AWS.Server.HTTP;
Line_Index : Positive;
C_Stat : in out AWS.Status.Data;
Expect_100 : Boolean)
is
use type Status.Request_Method;
Status_Multipart_Boundary : Unbounded_String;
Status_Root_Part_CID : Unbounded_String;
Status_Content_Type : Unbounded_String;
Sock : constant Net.Socket_Type'Class := Status.Socket (C_Stat);
Attachments : AWS.Attachments.List;
function Get_Line return String;
-- Read a line from Sock
procedure Read (Buffer : out Stream_Element_Array);
-- Fill buffer from Sock
procedure Read_Body (Stat : in out Status.Data; Boundary : String);
-- Read Sock until Boundary is found
procedure Check_Data_Timeout;
-- Check data time-out using server settings
------------------------
-- Check_Data_Timeout --
------------------------
procedure Check_Data_Timeout is
begin
HTTP_Server.Slots.Check_Data_Timeout (Line_Index);
end Check_Data_Timeout;
--------------
-- Get_Line --
--------------
function Get_Line return String is
begin
return Net.Buffered.Get_Line (Sock);
end Get_Line;
----------
-- Read --
----------
procedure Read (Buffer : out Stream_Element_Array) is
begin
Net.Buffered.Read (Sock, Buffer);
end Read;
---------------
-- Read_Body --
---------------
procedure Read_Body (Stat : in out Status.Data; Boundary : String) is
begin
Status.Set.Read_Body (Sock, Stat, Boundary => Boundary);
end Read_Body;
-----------------------
-- Multipart_Message --
-----------------------
package Multipart_Message is new Multipart_Message_G
(False, HTTP_Server.Properties,
Get_Line, Read, Read_Body, Check_Data_Timeout);
begin
if Expect_100 then
Net.Buffered.Put_Line (Sock, Messages.Status_Line (Messages.S100));
Net.Buffered.New_Line (Sock);
Net.Buffered.Flush (Sock);
end if;
-- Get necessary data from header for reading HTTP body
declare
procedure Named_Value
(Name, Value : String; Quit : in out Boolean);
-- Looking for the Boundary value in the Content-Type header line
procedure Value (Item : String; Quit : in out Boolean);
-- Reading the first unnamed value into the Status_Content_Type
-- variable from the Content-Type header line.
-----------------
-- Named_Value --
-----------------
procedure Named_Value
(Name, Value : String; Quit : in out Boolean)
is
pragma Unreferenced (Quit);
L_Name : constant String :=
Ada.Characters.Handling.To_Lower (Name);
begin
if L_Name = "boundary" then
Status_Multipart_Boundary := To_Unbounded_String (Value);
elsif L_Name = "start" then
Status_Root_Part_CID := To_Unbounded_String (Value);
end if;
end Named_Value;
-----------
-- Value --
-----------
procedure Value (Item : String; Quit : in out Boolean) is
begin
if Status_Content_Type /= Null_Unbounded_String then
-- Only first unnamed value is the Content_Type
Quit := True;
elsif Item'Length > 0 then
Status_Content_Type := To_Unbounded_String (Item);
end if;
end Value;
procedure Parse is new Headers.Values.Parse (Value, Named_Value);
begin
-- Clear Content-Type status as this could have already been set
-- in previous request.
Status_Content_Type := Null_Unbounded_String;
Parse (Status.Content_Type (C_Stat));
end;
if Status.Method (C_Stat) = Status.POST
and then Status_Content_Type = MIME.Application_Form_Data
then
-- Read data from the stream and convert it to a string as
-- these are a POST form parameters.
-- The body has the format: name1=value1&name2=value2...
Status.Set.Read_Body (Sock, C_Stat);
Status.Set.Parameters_From_Body (C_Stat);
elsif Status.Method (C_Stat) = Status.POST
and then Status_Content_Type = MIME.Multipart_Form_Data
then
-- This is a file upload
Multipart_Message.File_Upload
(C_Stat,
Attachments,
"--" & To_String (Status_Multipart_Boundary),
"--" & To_String (Status_Multipart_Boundary) & "--",
True);
elsif Status.Method (C_Stat) = Status.POST
and then Status_Content_Type = MIME.Multipart_Related
then
-- Attachments are to be written to separate files
Multipart_Message.Store_Attachments
(C_Stat,
Attachments,
"--" & To_String (Status_Multipart_Boundary),
"--" & To_String (Status_Multipart_Boundary) & "--",
True,
To_String (Status_Multipart_Boundary),
To_String (Status_Root_Part_CID));
else
-- Let's suppose for now that all others content type data are
-- binary data.
Status.Set.Read_Body (Sock, C_Stat);
end if;
Status.Reset_Body_Index (C_Stat);
HTTP_Server.Slots.Mark_Phase (Line_Index, Server_Processing);
Status.Set.Uploaded (C_Stat);
end Get_Message_Data;
----------------------
-- Get_Request_Line --
----------------------
procedure Get_Request_Line (C_Stat : in out AWS.Status.Data) is
use type Status.Protocol_State;
Sock : constant Net.Socket_Type'Class := Status.Socket (C_Stat);
begin
-- Get and parse request line
loop
declare
Data : constant String := Net.Buffered.Get_Line (Sock);
function Is_Next (Item : String) return Boolean is
(Net.Buffered.Get_Line (Sock) = Item);
begin
-- RFC 2616
-- 4.1 Message Types
-- ....................
-- In the interest of robustness, servers SHOULD ignore any empty
-- line(s) received where a Request-Line is expected.
if Data /= "" then
if not Sock.Is_Secure
and then Status.Protocol (C_Stat) = Status.HTTP_1
and then Data = HTTP2.Client_Connection_Preface_1
and then Is_Next ("")
and then Is_Next (HTTP2.Client_Connection_Preface_2)
and then Is_Next ("")
then
-- Plain socket client starts with HTTP/2 connection
-- preface, i.e. client assume that server has HTTP/2
-- support (RFC 7540, 3.4.). Set the Protocol to H2 and
-- check for HTTP/2 server support in Protocol_Handler where
-- this routine is called from.
Status.Set.Protocol (C_Stat, Status.H2);
exit;
end if;
Parse_Request_Line (Data, C_Stat);
exit;
end if;
end;
end loop;
end Get_Request_Line;
-------------------------
-- Get_Resource_Status --
-------------------------
function Get_Resource_Status
(C_Stat : Status.Data;
Filename : String;
File_Time : out Ada.Calendar.Time) return Resource_Status
is
F_Status : Resource_Status := Changed;
begin
File_Time := Utils.AWS_Epoch;
if Filename /= "" then
if Resources.Is_Regular_File (Filename) then
File_Time := Resources.File_Timestamp (Filename);
if Utils.Is_Valid_HTTP_Date (Status.If_Modified_Since (C_Stat))
and then
Messages.To_HTTP_Date (File_Time)
= Status.If_Modified_Since (C_Stat)
-- Equal used here see [RFC 2616 - 14.25]
then
F_Status := Up_To_Date;
else
F_Status := Changed;
end if;
else
F_Status := Not_Found;
end if;
end if;
return F_Status;
end Get_Resource_Status;
----------------
-- Log_Commit --
----------------
procedure Log_Commit
(HTTP_Server : in out AWS.Server.HTTP;
Answer : Response.Data;
C_Stat : AWS.Status.Data;
Length : Response.Content_Length_Type)
is
LA : constant Line_Attribute.Attribute_Handle :=
Line_Attribute.Reference;
Status_Code : constant Messages.Status_Code :=
Response.Status_Code (Answer);
begin
if LA.Skip_Log then
LA.Skip_Log := False;
elsif CNF.Log_Extended_Fields_Length (HTTP_Server.Properties) > 0 then
declare
use Real_Time;
use type Strings.Maps.Character_Set;
Start : constant Time := Status.Request_Time (C_Stat);
begin
if Start /= Time_First then
Log.Set_Field
(LA.Server.Log, LA.Log_Data, "time-taken",
Utils.Significant_Image (To_Duration (Clock - Start), 3));
end if;
Log.Set_Header_Fields
(LA.Server.Log, LA.Log_Data, "cs", Status.Header (C_Stat));
Log.Set_Header_Fields
(LA.Server.Log, LA.Log_Data, "sc", Response.Header (Answer));
Log.Set_Field
(LA.Server.Log, LA.Log_Data, "cs-method",
Status.Method (C_Stat));
Log.Set_Field
(LA.Server.Log, LA.Log_Data, "cs-username",
Status.Authorization_Name (C_Stat));
Log.Set_Field
(LA.Server.Log, LA.Log_Data, "cs-version",
Status.HTTP_Version (C_Stat));
declare
use AWS.URL;
Encoding : constant Strings.Maps.Character_Set :=
Strings.Maps.To_Set
(Span => (Low => Character'Val (128),
High => Character'Last))
or Strings.Maps.To_Set ("+"" ");
URI : constant String :=
Encode (Status.URI (C_Stat), Encoding);
Query : constant String :=
Parameters.URI_Format
(Status.Parameters (C_Stat));
begin
Log.Set_Field (LA.Server.Log, LA.Log_Data, "cs-uri-stem", URI);
Log.Set_Field
(LA.Server.Log, LA.Log_Data, "cs-uri-query", Query);
Log.Set_Field
(LA.Server.Log, LA.Log_Data, "cs-uri", URI & Query);
end;
Log.Set_Field
(LA.Server.Log, LA.Log_Data, "sc-status",
Messages.Image (Status_Code));
Log.Set_Field
(LA.Server.Log, LA.Log_Data, "sc-bytes", Utils.Image (Length));
Log.Write (LA.Server.Log, LA.Log_Data);
end;
else
Log.Write (HTTP_Server.Log, C_Stat, Status_Code, Length);
end if;
end Log_Commit;
-------------------------
-- Parse_Content_Range --
-------------------------
procedure Parse_Content_Range
(H_Value : String;
Length : Stream_Element_Offset;
First : out Stream_Element_Offset;
Last : out Stream_Element_Offset)
is
I_Minus : constant Positive := Fixed.Index (H_Value, "-");
begin
-- Computer First / Last and the range length
if I_Minus = H_Value'Last then
Last := Length - 1;
else
Last := Stream_Element_Offset'Value
(H_Value (I_Minus + 1 .. H_Value'Last));
if Last >= Length then
Last := Length - 1;
end if;
end if;
if H_Value'First = I_Minus then
-- In this case we want to get the last N bytes from the file
First := Length - Last;
Last := Length - 1;
else
First := Stream_Element_Offset'Value
(H_Value (H_Value'First .. I_Minus - 1));
end if;
end Parse_Content_Range;
------------------------
-- Parse_Request_Line --
------------------------
procedure Parse_Request_Line
(Command : String; C_Stat : in out AWS.Status.Data)
is
I1, I2 : Natural;
-- Index of first space and second space
Path_Last : Positive;
-- Last index of Path part
Query_First : Positive;
-- First index of Query part
procedure Raise_Wrong_Line;
-- Raise Wrong_Request_Line exception with text message
----------------------
-- Raise_Wrong_Line --
----------------------
procedure Raise_Wrong_Line is
begin
raise Wrong_Request_Line with "Wrong request line '" & Command & ''';
end Raise_Wrong_Line;
begin
I1 := Fixed.Index (Command, " ");
if I1 = 0 then
Raise_Wrong_Line;
end if;
I2 := Fixed.Index (Command (I1 + 1 .. Command'Last), " ", Backward);
if I2 = 0 or else I1 = I2 then
Raise_Wrong_Line;
end if;
if I2 + 5 >= Command'Last
or else Command (I2 + 1 .. I2 + 5) /= "HTTP/"
then
Raise_Wrong_Line;
end if;
Split_Path (Command (I1 + 1 .. I2 - 1), Path_Last, Query_First);
-- GET and HEAD can have a set of parameters (query) attached. This is
-- not really standard see [RFC 2616 - 13.9] but is widely used now.
--
-- POST parameters are passed into the message body, but we allow
-- parameters also in this case. It is not clear if it is permitted or
-- prohibited by reading RFC 2616. Other technologies do offer this
-- feature so AWS do this as well.
Status.Set.Request
(C_Stat,
Method => Command (Command'First .. I1 - 1),
URI => Command (I1 + 1 .. Path_Last),
HTTP_Version => Command (I2 + 1 .. Command'Last));
Status.Set.Query
(C_Stat,
Parameters => Command (Query_First .. I2 - 1));
end Parse_Request_Line;
----------
-- Send --
----------
procedure Send
(Answer : in out Response.Data;
HTTP_Server : in out AWS.Server.HTTP;
Line_Index : Positive;
C_Stat : AWS.Status.Data;
Socket_Taken : in out Boolean;
Will_Close : in out Boolean)
is
Status_Code : Messages.Status_Code := Response.Status_Code (Answer);
Length : Resources.Content_Length_Type := 0;
H_List : Headers.List;
procedure Set_General_Header (Status_Code : Messages.Status_Code);
-- Send the "Date:", "Server:", "Set-Cookie:" and "Connection:" header
procedure Send_Header_Only;
-- Send HTTP message header only. This is used to implement the HEAD
-- request.
procedure Send_Data;
-- Send a text/binary data to the client
procedure Send_WebSocket_Handshake;
-- Send reply, accept the switching protocol
procedure Send_WebSocket_Handshake_Error
(Status_Code : Messages.Status_Code;
Reason_Phrase : String := "");
-- Deny the WebSocket handshake
---------------
-- Send_Data --
---------------
procedure Send_Data is
use type AWS.Status.Request_Method;
Sock : constant Net.Socket_Type'Class :=
Status.Socket (C_Stat);
Method : constant AWS.Status.Request_Method :=
Status.Method (C_Stat);
Filename : constant String :=
Response.Filename (Answer);
File_Mode : constant Boolean :=
Response.Mode (Answer) in
Response.File .. Response.Stream;
With_Body : constant Boolean := Messages.With_Body (Status_Code);
File_Time : Ada.Calendar.Time;
F_Status : constant Resource_Status :=
Get_Resource_Status (C_Stat, Filename, File_Time);
File : Resources.File_Type;
begin
if F_Status in Up_To_Date .. Not_Found then
if F_Status = Up_To_Date then
-- [RFC 2616 - 10.3.5]
Status_Code := Messages.S304;
else
-- File is not found on disk, returns now with 404
Status_Code := Messages.S404;
end if;
Set_General_Header (Status_Code);
Headers.Send_Header
(Socket => Sock, Headers => H_List, End_Block => True);
return;
elsif Headers.Get_Values
(Status.Header (C_Stat), Messages.Range_Token) /= ""
and then With_Body
then
-- Partial range request, answer accordingly
Status_Code := Messages.S206;
end if;
-- Note. We have to call Create_Resource before send header fields
-- defined in the Answer to the client, because this call could
-- setup Content-Encoding header field to Answer. Answer header
-- lines would be send below in the Send_General_Header.
Response.Create_Resource
(Answer, File, AWS.Status.Is_Supported (C_Stat, Messages.GZip));
-- Length is the real resource/file size
Length := Resources.Size (File);
-- Checking if we have to close connection because of undefined
-- message length coming from a user's stream. Or because of user
-- do not want to keep connection alive.
if (Length = Resources.Undefined_Length
and then Status.HTTP_Version (C_Stat) = HTTP_10
-- We cannot use transfer-encoding chunked in HTTP_10
and then Method /= Status.HEAD)
-- We have to send message_body
or else not Response.Keep_Alive (Answer)
then
-- In this case we need to close the connection explicitly at the
-- end of the transfer.
Will_Close := True;
end if;
Set_General_Header (Status_Code);
-- Send file last-modified timestamp info in case of a file
if File_Mode
and then
not Response.Has_Header (Answer, Messages.Last_Modified_Token)
then
Headers.Add
(Table => H_List,
Name => Messages.Last_Modified_Token,
Value => Messages.To_HTTP_Date (File_Time));
end if;
-- Send Cache-Control, Location, WWW-Authenticate and others
-- user defined header lines.
Headers.Send_Header
(Socket => Sock,
Headers => H_List,
End_Block => False);
Response.Send_Header (Socket => Sock, D => Answer);
-- Note that we cannot send the Content_Length header at this
-- point. A server should not send Content_Length if the
-- transfer-coding used is not identity. This is allowed by the
-- RFC but it seems that some implementation does not handle this
-- right. The file can be sent using either identity or chunked
-- transfer-coding. The proper header will be sent in Send_Resource
-- see [RFC 2616 - 4.4].
-- Send message body
if With_Body then
Send_Resource
(Answer, File, Length, HTTP_Server.Self, Line_Index, C_Stat);
else
-- RFC-2616 4.4
-- ...
-- Any response message which "MUST NOT" include a message-body
-- (such as the 1xx, 204, and 304 responses and any response to a
-- HEAD request) is always terminated by the first empty line
-- after the header fields, regardless of the entity-header fields
-- present in the message.
Net.Buffered.New_Line (Sock);
if Length > 0 then
Log.Write
(HTTP_Server.Error_Log, C_Stat,
"Message body was not sent. Response with status '"
& Messages.Image (Status_Code) & "' can't have it.");
end if;
end if;
Net.Buffered.Flush (Sock);
end Send_Data;
----------------------
-- Send_Header_Only --
----------------------
procedure Send_Header_Only is
begin
-- First let's output the status line
Set_General_Header (Status_Code);
Headers.Add
(Table => H_List,
Name => Messages.Content_Type_Token,
Value => Response.Content_Type (Answer));
-- There is no content
Headers.Add
(Table => H_List,
Name => Messages.Content_Length_Token,
Value => Utils.Image (Stream_Element_Offset'(0)));
-- Send Cache-Control, Location, WWW-Authenticate and others
-- user defined header lines.
Headers.Send_Header
(Socket => Status.Socket (C_Stat),
Headers => H_List,
End_Block => False);
Response.Send_Header
(Socket => Status.Socket (C_Stat),
D => Answer,
End_Block => True);
end Send_Header_Only;
------------------------------
-- Send_WebSocket_Handshake --
------------------------------
procedure Send_WebSocket_Handshake is
Sock : constant Net.Socket_Type'Class := Status.Socket (C_Stat);
Headers : constant AWS.Headers.List := Status.Header (C_Stat);
begin
-- First let's output the status line
Net.Buffered.Put_Line (Sock, Messages.Status_Line (Status_Code));
-- Send Cache-Control, Location, WWW-Authenticate and others
-- user defined header lines.
Response.Send_Header (Socket => Sock, D => Answer);
if Headers.Exist (Messages.Sec_WebSocket_Key1_Token)
and then Headers.Exist (Messages.Sec_WebSocket_Key2_Token)
then
Net.WebSocket.Protocol.Draft76.Send_Header (Sock, C_Stat);
else
-- Send WebSocket-Accept handshake
Net.WebSocket.Protocol.RFC6455.Send_Header (Sock, C_Stat);
-- End of header
Net.Buffered.New_Line (Sock);
Net.Buffered.Flush (Sock);
end if;
end Send_WebSocket_Handshake;
------------------------------------
-- Send_WebSocket_Handshake_Error --
------------------------------------
procedure Send_WebSocket_Handshake_Error
(Status_Code : Messages.Status_Code;
Reason_Phrase : String := "")
is
Sock : constant Net.Socket_Type'Class := Status.Socket (C_Stat);
begin
-- First let's output the status line
Net.Buffered.Put_Line
(Sock, Messages.Status_Line (Status_Code, Reason_Phrase));
Net.Buffered.Put_Line (Sock, Messages.Content_Length (0));
-- End of header
Net.Buffered.New_Line (Sock);
Net.Buffered.Flush (Sock);
end Send_WebSocket_Handshake_Error;
------------------------
-- Set_General_Header --
------------------------
procedure Set_General_Header (Status_Code : Messages.Status_Code) is
begin
-- The status line
Headers.Add
(Table => H_List,
Name => HTTP_Version,
Value => Messages.Status_Value (Status_Code));
-- Date
Headers.Add
(Table => H_List,
Name => Messages.Date_Token,
Value => Messages.To_HTTP_Date (Utils.GMT_Clock));
-- Server
declare
Server : constant String :=
CNF.Server_Header (HTTP_Server.Properties);
begin
if Server /= "" then
Headers.Add
(Table => H_List,
Name => Messages.Server_Token,
Value => Server);
end if;
end;
-- Session
if CNF.Session (HTTP_Server.Properties)
and then AWS.Status.Session_Created (C_Stat)
then
-- This is an HTTP connection with session but there is no session
-- ID set yet. So, send cookie to client browser.
Headers.Add
(Table => H_List,
Name => Messages.Set_Cookie_Token,
Value => CNF.Session_Name (HTTP_Server.Properties) & '='
& Session.Image (AWS.Status.Session (C_Stat))
& "; path=/; Version=1");
-- And the internal private session
Headers.Add
(Table => H_List,
Name => Messages.Set_Cookie_Token,
Value => CNF.Session_Private_Name (HTTP_Server.Properties) & '='
& AWS.Status.Session_Private (C_Stat)
& "; path=/; Version=1");
end if;
if Will_Close then
-- We have decided to close connection after answering the client
Headers.Add
(H_List, Messages.Connection_Token, Value => "close");
else
Headers.Add
(H_List, Messages.Connection_Token, Value => "keep-alive");
end if;
end Set_General_Header;
begin
case Response.Mode (Answer) is
when Response.File | Response.File_Once | Response.Stream
| Response.Message
=>
HTTP_Server.Slots.Mark_Phase (Line_Index, Server_Response);
Send_Data;
when Response.Header =>
HTTP_Server.Slots.Mark_Phase (Line_Index, Server_Response);
Send_Header_Only;
when Response.Socket_Taken =>
HTTP_Server.Slots.Socket_Taken (Line_Index);
Socket_Taken := True;
when Response.WebSocket =>
Socket_Taken := False;
Will_Close := True;
if not CNF.Is_WebSocket_Origin_Set
or else GNAT.Regexp.Match
(Status.Origin (C_Stat), CNF.WebSocket_Origin)
then
-- Get the WebSocket
begin
declare
-- The call to the constructor will raise an exception
-- if the WebSocket is not to be accepted. In this case
-- a forbidden message is sent back.
WS : constant Net.WebSocket.Object'Class :=
Net.WebSocket.Registry.Constructor
(Status.URI (C_Stat))
(Socket => Status.Socket (C_Stat),
Request => C_Stat);
begin
-- Register this new WebSocket
if WS in Net.WebSocket.Handshake_Error.Object'Class then
declare
E : constant Net.WebSocket.Handshake_Error.Object :=
Net.WebSocket.Handshake_Error.Object (WS);
begin
Send_WebSocket_Handshake_Error
(E.Status_Code, E.Reason_Phrase);
end;
else
-- First try to register the WebSocket object
declare
use type Net.WebSocket.Object_Class;
W : Net.WebSocket.Object_Class;
begin
W := Net.WebSocket.Registry.Utils.Register (WS);
if W = Net.WebSocket.No_Object then
Send_WebSocket_Handshake_Error
(Messages.S412,
"too many WebSocket registered");
else
Send_WebSocket_Handshake;
HTTP_Server.Slots.Socket_Taken (Line_Index);
Socket_Taken := True;
Will_Close := False;
Net.WebSocket.Registry.Utils.Watch (W);
end if;
end;
end if;
exception
when E : others =>
Send_WebSocket_Handshake_Error
(Messages.S403,
Exception_Message (E));
WS.Shutdown;
end;
exception
when E : others =>
Send_WebSocket_Handshake_Error
(Messages.S403,
Exception_Message (E));
raise;
end;
else
Send_WebSocket_Handshake_Error (Messages.S403);
end if;
when Response.No_Data =>
raise Constraint_Error
with "Answer not properly initialized (No_Data)";
end case;
-- Status code can be modified, set it back for the logging
Response.Set.Status_Code (Answer, Status_Code);
Log_Commit (HTTP_Server, Answer, C_Stat, Length);
end Send;
-----------------
-- Send_File_G --
-----------------
procedure Send_File_G
(HTTP_Server : access AWS.Server.HTTP;
Line_Index : Positive;
File : in out Resources.File_Type;
Start : Stream_Element_Offset;
Chunk_Size : Stream_Element_Count;
Length : in out Resources.Content_Length_Type)
is
Next_Size : Stream_Element_Count := Chunk_Size;
begin
Resources.Set_Index (File, Start);
loop
declare
-- Size of the buffer used to send the file
Last : Streams.Stream_Element_Offset;
Buffer : Streams.Stream_Element_Array (1 .. Next_Size);
begin
Resources.Read (File, Buffer, Last);
if Resources.End_Of_File (File) then
Next_Size := 0;
end if;
if Last >= Buffer'First then
Data (Buffer (1 .. Last), Next_Size);
Length := Length + Last;
end if;
exit when Next_Size = 0;
-- HTTP_Server is only set when used in server context. When used
-- in client context it is not defined and we do not check for
-- timeout.
if HTTP_Server /= null then
HTTP_Server.Slots.Check_Data_Timeout (Line_Index);
end if;
end;
end loop;
end Send_File_G;
------------------------
-- Send_File_Ranges_G --
------------------------
procedure Send_File_Ranges_G
(HTTP_Server : access AWS.Server.HTTP;
Line_Index : Positive;
File : in out Resources.File_Type;
Ranges : String;
Chunk_Size : Stream_Element_Count;
Length : in out Resources.Content_Length_Type;
Answer : in out Response.Data)
is
Boundary : constant String := "aws_range_separator";
N_Range : constant Positive := 1 + Fixed.Count (Ranges, ",");
N_Minus : constant Natural := Fixed.Count (Ranges, "-");
-- Number of ranges defined
Equal : constant Natural := Fixed.Index (Ranges, "=");
First, Last : Positive;
Next_Size : Stream_Element_Offset := Chunk_Size;
procedure Send_Range (R : String);
-- Send a single range as defined by R
procedure Send (Str : String; Last_One : Boolean := False) with Inline;
----------
-- Send --
----------
procedure Send (Str : String; Last_One : Boolean := False) is
Buffer : constant Stream_Element_Array :=
Translator.To_Stream_Element_Array (Str);
First : Stream_Element_Offset := Buffer'First;
Last : Stream_Element_Offset;
begin
loop
Last := Stream_Element_Offset'Min
(First + Next_Size - 1, Buffer'Last);
if Last_One and then Last = Buffer'Last then
Next_Size := 0;
end if;
Data (Buffer (First .. Last), Next_Size);
exit when Last = Buffer'Last;
First := Last + 1;
end loop;
end Send;
----------------
-- Send_Range --
----------------
procedure Send_Range (R : String) is
R_First : Stream_Element_Offset;
R_Last : Stream_Element_Offset;
R_Length : Stream_Element_Offset;
begin
if N_Range /= 1 then
-- Send the multipart/byteranges
Send ("--" & Boundary & CRLF);
end if;
Parse_Content_Range (R, Length, R_First, R_Last);
R_Length := R_Last - R_First + 1;
if N_Range /= 1 or else not Is_H2 then
-- Only issue the Content-Range & Content-Length header in HTTP/1
-- or if there is multiple ranges as this will be part of the
-- body.
--
-- Content-Range: bytes -/
Send
(Messages.Content_Range_Token & ": bytes "
& Utils.Image (R_First) & "-"
& Utils.Image (R_Last)
& "/" & Utils.Image (Length)
& CRLF
& Messages.Content_Length (R_Length) & CRLF & CRLF);
end if;
Resources.Set_Index (File, R_First + 1);
declare
Buffer : Streams.Stream_Element_Array (1 .. Chunk_Size);
Sent : Stream_Element_Offset := 0;
Size : Stream_Element_Offset := 0;
Last : Stream_Element_Offset;
begin
loop
Size := R_Length - Sent;
exit when Size = 0;
if Size > Next_Size then
Size := Next_Size;
elsif N_Range = 1 then
Next_Size := 0;
end if;
Resources.Read (File, Buffer (1 .. Size), Last);
exit when Last < Buffer'First;
Data (Buffer (1 .. Last), Next_Size);
Sent := Sent + Last;
HTTP_Server.Slots.Check_Data_Timeout (Line_Index);
end loop;
end;
end Send_Range;
begin
-- In HTTP/2 mode the headers have already been taken care of
if not Is_H2 then
-- Check range definition
if N_Range /= N_Minus
or else Equal = 0
or else Ranges (Ranges'First .. Equal - 1) /= "bytes"
then
-- Range is wrong, let's send the whole file then
Send_File (HTTP_Server, Line_Index, File, 1, Chunk_Size, Length);
return;
end if;
if N_Range = 1 then
Send
(Messages.Content_Type (Response.Content_Type (Answer)) & CRLF);
else
-- Then we will send a multipart/byteranges
Send
(Messages.Content_Type
(MIME.Multipart_Byteranges & "; boundary=" & Boundary)
& CRLF);
end if;
end if;
First := Equal + 1;
for K in 1 .. N_Range loop
if K = N_Range then
Last := Ranges'Last;
else
Last := Fixed.Index (Ranges (First .. Ranges'Last), ",") - 1;
end if;
Send_Range (Ranges (First .. Last));
First := Last + 2;
end loop;
-- End the multipart/byteranges message
if N_Range /= 1 then
-- Send the multipart/byteranges
Send ("--" & Boundary & "--" & CRLF, Last_One => True);
end if;
end Send_File_Ranges_G;
-------------------
-- Send_Resource --
-------------------
procedure Send_Resource
(Answer : in out Response.Data;
File : in out Resources.File_Type;
Length : in out Resources.Content_Length_Type;
HTTP_Server : access AWS.Server.HTTP;
Line_Index : Positive;
C_Stat : AWS.Status.Data)
is
use type Status.Request_Method;
Sock : constant Net.Socket_Type'Class := Status.Socket (C_Stat);
Method : constant AWS.Status.Request_Method :=
Status.Method (C_Stat);
Chunk_Size : constant := 1_024;
-- Size of the buffer used to send the file with the chunked encoding.
-- This is the maximum size of each chunk.
Ranges : constant String :=
Headers.Get_Values
(Status.Header (C_Stat), Messages.Range_Token);
-- The ranges for partial sending if defined
Close : constant Boolean := Response.Close_Resource (Answer);
procedure Send_File;
-- Send file in one part
procedure Send_Ranges;
-- Send a set of ranges of file content
procedure Send_File_Chunked;
-- Send file in chunks, used in HTTP/1.1 and when the message length
-- is not known)
procedure Data_Received
(Content : Stream_Element_Array;
Next_Size : in out Stream_Element_Count);
-- New data received
Last : Streams.Stream_Element_Offset;
-------------------
-- Data_Received --
-------------------
procedure Data_Received
(Content : Stream_Element_Array;
Next_Size : in out Stream_Element_Count)
is
pragma Unreferenced (Next_Size);
begin
Net.Buffered.Write (Sock, Content);
end Data_Received;
procedure Send_File_Content is new Send_File_G (Data_Received);
---------------
-- Send_File --
---------------
procedure Send_File is
begin
Send_File_Content
(HTTP_Server, Line_Index, File, 1,
Chunk_Size => 4 * 1024,
Length => Length);
end Send_File;
---------------------
-- Send_File_Chunk --
---------------------
procedure Send_File_Chunked is
-- Note that we do not use a buffered socket here. Opera on SSL
-- sockets does not like chunk that are not sent in a whole.
Buffer : Streams.Stream_Element_Array (1 .. Chunk_Size);
-- Each chunk will have a maximum length of Buffer'Length
CRLF : constant Streams.Stream_Element_Array :=
(1 => Character'Pos (ASCII.CR),
2 => Character'Pos (ASCII.LF));
Last_Chunk : constant Streams.Stream_Element_Array :=
Character'Pos ('0') & CRLF & CRLF;
-- Last chunk for a chunked encoding stream. See [RFC 2616 - 3.6.1]
begin
Send_Chunks : loop
Resources.Read (File, Buffer, Last);
if Last = 0 then
-- There is not more data to read, the previous chunk was the
-- last one, just terminate the chunk message here.
Net.Send (Sock, Last_Chunk);
exit Send_Chunks;
end if;
Length := Length + Last;
HTTP_Server.Slots.Check_Data_Timeout (Line_Index);
declare
H_Last : constant String := Utils.Hex (Positive (Last));
Chunk : constant Streams.Stream_Element_Array :=
Translator.To_Stream_Element_Array (H_Last)
& CRLF & Buffer (1 .. Last) & CRLF;
-- A chunk is composed of:
-- the Size of the chunk in hexadecimal
-- a line feed
-- the chunk
-- a line feed
begin
-- Check if the last data portion
if Last < Buffer'Last then
-- No more data, add the terminating chunk
Net.Send (Sock, Chunk & Last_Chunk);
exit Send_Chunks;
else
Net.Send (Sock, Chunk);
end if;
end;
end loop Send_Chunks;
end Send_File_Chunked;
-----------------
-- Send_Ranges --
-----------------
procedure Send_Ranges is
procedure Send_Ranges_Content is
new Send_File_Ranges_G (Data_Received, Send_File_Content, False);
begin
Send_Ranges_Content
(HTTP_Server, Line_Index, File, Ranges, 4096, Length, Answer);
end Send_Ranges;
begin
if Ranges /= "" and then Length /= Resources.Undefined_Length then
-- Range: header present, we need to send only the specified bytes
Net.Buffered.Put_Line
(Sock, Messages.Accept_Ranges_Token & ": bytes");
-- Only bytes supported
Send_Ranges;
elsif Status.HTTP_Version (C_Stat) = HTTP_10
or else Length /= Resources.Undefined_Length
then
Net.Buffered.Put_Line
(Sock, Messages.Content_Type (Response.Content_Type (Answer)));
-- If content length is undefined and we handle an HTTP/1.0 protocol
-- then the end of the stream will be determined by closing the
-- connection. [RFC 1945 - 7.2.2] See the Will_Close local variable.
if Length /= Resources.Undefined_Length
and then not Response.Has_Header
(Answer, Messages.Content_Length_Token)
then
Net.Buffered.Put_Line (Sock, Messages.Content_Length (Length));
end if;
-- Terminate header
Net.Buffered.New_Line (Sock);
if Method /= Status.HEAD and then Length /= 0 then
Length := 0;
Send_File;
end if;
else
Net.Buffered.Put_Line
(Sock, Messages.Content_Type (Response.Content_Type (Answer)));
-- HTTP/1.1 case and we do not know the message length
--
-- Terminate header, do not send the Content_Length see
-- [RFC 2616 - 4.4]. It could be possible to send the Content_Length
-- as this is cleary a permission but it does not work in some
-- obsucre cases.
Net.Buffered.Put_Line (Sock, Messages.Transfer_Encoding ("chunked"));
Net.Buffered.New_Line (Sock);
Net.Buffered.Flush (Sock);
-- Past this point we will not use the buffered mode. Opera on SSL
-- sockets does not like chunk that are not sent in a whole.
if Method /= Status.HEAD then
Length := 0;
Send_File_Chunked;
end if;
end if;
if Close then
Resources.Close (File);
end if;
exception
when others =>
if Close then
Resources.Close (File);
end if;
raise;
end Send_Resource;
----------------------
-- Set_Close_Status --
----------------------
procedure Set_Close_Status
(C_Stat : AWS.Status.Data;
Keep_Alive : Boolean;
Will_Close : in out Boolean)
is
Connection : constant String := Status.Connection (C_Stat);
begin
-- Connection, check connection string with Match to skip connection
-- options [RFC 2616 - 14.10].
Will_Close := Utils.Match (Connection, "close")
or else not Keep_Alive
or else (Status.HTTP_Version (C_Stat) = HTTP_10
and then not Utils.Match (Connection, "keep-alive"));
end Set_Close_Status;
----------------
-- Split_Path --
----------------
procedure Split_Path
(Path : String;
Path_Last, Query_First : out Positive)
is
Delimiter : Natural := Fixed.Index (Path, "?");
begin
if Delimiter /= 0 then
Path_Last := Delimiter - 1;
Query_First := Delimiter + 1;
return;
end if;
-- ? Could be encoded %3f
Delimiter := Fixed.Index (Path, "%3f");
if Delimiter = 0 then
Delimiter := Fixed.Index (Path, "%3F");
end if;
if Delimiter = 0 then
Query_First := Path'Last + 1;
Path_Last := Path'Last;
else
Query_First := Delimiter + 3;
Path_Last := Delimiter - 1;
end if;
end Split_Path;
end AWS.Server.HTTP_Utils;