------------------------------------------------------------------------------ -- 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.Exceptions; with Ada.Streams.Stream_IO; with Ada.Strings.Fixed; with Ada.Strings.Maps; with AWS.Digest; with AWS.Headers.Values; with AWS.HTTP2.Connection; with AWS.HTTP2.Frame.GoAway; with AWS.HTTP2.Frame.List; with AWS.HTTP2.Message; with AWS.HTTP2.Stream; with AWS.Messages; with AWS.MIME; with AWS.Net.Buffered; with AWS.Net.SSL; with AWS.Resources.Files; with AWS.Response.Set; with AWS.Server.Context; with AWS.Server.HTTP_Utils; with AWS.Translator; with AWS.Utils; package body AWS.Client.HTTP_Utils is function Image (Data_Range : Content_Range) return String; -- Returns the partial content range parameter to be passed to the Range -- header. function "+" (Left : Real_Time.Time; Right : Real_Time.Time_Span) return Real_Time.Time; -- Returns Real_Time.Time_Last if Right is Real_Time.Time_Span_Last, -- otherwise returns Left + Right. procedure Send_Request_1 (Connection : in out HTTP_Connection; Kind : Method_Kind; Result : out Response.Data; URI : String; Data : Stream_Element_Array := No_Data; Headers : Header_List := Empty_Header_List); -- Send a simple GET request data For HTTP/1 procedure Send_Request_2 (Connection : in out HTTP_Connection; Kind : Method_Kind; Result : out Response.Data; URI : String; Data : Stream_Element_Array := No_Data; Headers : Header_List := Empty_Header_List); -- Send a simple GET request data For HTTP/2 procedure Internal_Post_Without_Attachment_1 (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Stream_Element_Array; URI : String; SOAPAction : String; Content_Type : String; Headers : Header_List := Empty_Header_List); -- Send a simple POST request data For HTTP/1 procedure Internal_Post_Without_Attachment_2 (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Stream_Element_Array; URI : String; SOAPAction : String; Content_Type : String; Headers : Header_List := Empty_Header_List); -- Send a simple POST request data For HTTP/2 procedure Internal_Post_With_Attachment_1 (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Stream_Element_Array; URI : String; SOAPAction : String; Content_Type : String; Attachments : Attachment_List; Headers : Header_List := Empty_Header_List); -- Send a simple POST request data For HTTP/1 procedure Internal_Post_With_Attachment_2 (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Stream_Element_Array; URI : String; SOAPAction : String; Content_Type : String; Attachments : Attachment_List; Headers : Header_List := Empty_Header_List); -- Send a simple POST request data For HTTP/2 procedure Send_H2_Connection_Preface (Connection : in out HTTP_Connection) with Pre => not Connection.H2_Preface_Sent; -- Send connection preface and get response from server procedure Next_Stream_Id (Connection : in out HTTP_Connection); -- Update client's stream-id to next value procedure Get_H2_Frame (Connection : in out HTTP_Connection; Ctx : in out Server.Context.Object; Stream : in out HTTP2.Stream.Object; Result : out Response.Data); -- Process incoming HTTP/2 frame procedure Send_H2_Request (Connection : in out HTTP_Connection; Ctx : in out Server.Context.Object; Stream : in out HTTP2.Stream.Object; Request : in out HTTP2.Message.Object); -- Send H2 request procedure Get_H2_Response (Connection : in out HTTP_Connection; Ctx : in out Server.Context.Object; Stream : in out HTTP2.Stream.Object; Result : out Response.Data); -- Get H2 response procedure Handle_H2_Request (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Stream_Element_Array; Auth_Attempts : in out Auth_Attempts_Count; Auth_Is_Over : out Boolean); -- Send request and get response for HTTP/2 protocol procedure Internal_Upload_1 (Connection : in out HTTP_Connection; Result : out Response.Data; Filename : String; URI : String; Headers : Header_List := Empty_Header_List; Progress : access procedure (Total, Sent : Stream_Element_Offset) := null); -- Upload for HTTP/1 procedure Internal_Upload_2 (Connection : in out HTTP_Connection; Result : out Response.Data; Filename : String; URI : String; Headers : Header_List := Empty_Header_List; Progress : access procedure (Total, Sent : Stream_Element_Offset) := null); -- Upload for HTTP/2 --------- -- "+" -- --------- function "+" (Left : Real_Time.Time; Right : Real_Time.Time_Span) return Real_Time.Time is use Real_Time; begin if Right = Time_Span_Last then return Time_Last; else return Real_Time."+" (Left, Right); end if; end "+"; ------------- -- Connect -- ------------- procedure Connect (Connection : in out HTTP_Connection) is use type Net.Socket_Access; use type Net.SSL.Session_Type; Connect_URL : AWS.URL.Object renames Connection.Connect_URL; Security : constant Boolean := AWS.URL.Security (Connect_URL); Sock : Net.Socket_Access; procedure Get_SSL_Session; -- Get SSL session data from connectio socket and store it into -- connection record. procedure Set_SSL_Session; -- Set SSL session data from connection record to connection socket --------------------- -- Get_SSL_Session -- --------------------- procedure Get_SSL_Session is begin if Connection.SSL_Session /= Net.SSL.Null_Session then Net.SSL.Free (Connection.SSL_Session); end if; Connection.SSL_Session := Net.SSL.Socket_Type (Connection.Socket.all).Session_Data; end Get_SSL_Session; --------------------- -- Set_SSL_Session -- --------------------- procedure Set_SSL_Session is begin if Connection.SSL_Session /= Net.SSL.Null_Session then -- Try to reuse SSL session to speedup handshake Net.SSL.Socket_Type (Connection.Socket.all).Set_Session_Data (Connection.SSL_Session); end if; end Set_SSL_Session; begin pragma Assert (not Connection.Opened); -- This should never be called with an open connection -- Keep-alive reconnection will be with old socket. We cannot reuse it, -- and have to free it. if Connection.Socket /= null then Net.Free (Connection.Socket); end if; Sock := Net.Socket (Security); Connection.Socket := Sock; Connection.H2_Preface_Sent := False; -- Set default HTTP2 connection settings Connection.H2_Settings := HTTP_Utils.Get_Settings (Connection.Config); HTTP2.Connection.Set (Connection.H2_Connection, Connection.H2_Settings); Connection.Enc_Table.Clear; Connection.Dec_Table.Clear; if Security then -- This is a secure connection, set the SSL config for this socket Net.SSL.Socket_Type (Sock.all).Set_Config (Connection.SSL_Config); Set_SSL_Session; end if; Sock.Set_Timeout (Connection.Timeouts.Connect); Sock.Connect (AWS.URL.Host (Connect_URL), AWS.URL.Port (Connect_URL)); if Security then -- Save SSL session to be able to reuse it later Get_SSL_Session; end if; Connection.Opened := True; if AWS.URL.Security (Connection.Host_URL) and then Connection.Proxy /= Client.No_Data then -- We want to connect to the host using HTTPS, this can only be -- done by opening a tunnel through the proxy. -- -- CONNECT HTTP/1.1 -- Host: -- [Proxy-Authorization: xxxx] -- -- Sock.Set_Timeout (Connection.Timeouts.Send); declare use AWS.URL; Host_Address : constant String := Host (Connection.Host_URL, IPv6_Brackets => True) & ':' & Port (Connection.Host_URL); begin Set_Header (Connection.F_Headers, Messages.Connect_Token, Host_Address & ' ' & AWS.HTTP_Version); Set_Header (Connection.F_Headers, Messages.Host_Token, Host_Address); end; -- Proxy Authentication Set_Authentication_Header (Connection, Messages.Proxy_Authorization_Token, Connection.Auth (Proxy), URI => "/", Method => Messages.Connect_Token); if Connection.User_Agent /= Null_Unbounded_String then Set_Header (Connection.F_Headers, Messages.User_Agent_Token, To_String (Connection.User_Agent)); end if; -- Send CONNECT command with headers to proxy Headers.Send_Header (Sock.all, Connection.F_Headers, End_Block => True); -- Wait for reply from the proxy, and check status Sock.Set_Timeout (Connection.Timeouts.Receive); declare use type Messages.Status_Code; Line : constant String := Net.Buffered.Get_Line (Sock.all); Status : Messages.Status_Code; begin Debug_Message ("< ", Line); Status := Messages.Status_Code'Value ('S' & Line (Messages.HTTP_Token'Length + 5 .. Messages.HTTP_Token'Length + 7)); if Status >= Messages.S400 then raise Connection_Error with "Can't connect to proxy, status " & Messages.Image (Status); end if; end; -- Ignore all remainings lines loop declare Line : constant String := Net.Buffered.Get_Line (Sock.all); begin Debug_Message ("< ", Line); exit when Line = ""; end; end loop; -- Now the tunnel is open, we need to create an SSL connection -- around this tunnel. declare SS : Net.SSL.Socket_Type := Net.SSL.Secure_Client (Sock.all, Connection.SSL_Config, Host => URL.Host (Connection.Host_URL)); begin Net.Free (Sock); Connection.Socket := new Net.SSL.Socket_Type'(SS); Set_SSL_Session; -- Do explicit handshake to be able to get server certificate -- and SSL session after. SS.Do_Handshake; Get_SSL_Session; end; end if; exception when E : Net.Socket_Error => raise Connection_Error with Exceptions.Exception_Message (E); end Connect; -------------------------------------- -- Decrement_Authentication_Attempt -- -------------------------------------- procedure Decrement_Authentication_Attempt (Connection : in out HTTP_Connection; Counter : in out Auth_Attempts_Count; Over : out Boolean) is type Over_Data is array (Authentication_Level) of Boolean; Is_Over : constant Over_Data := (others => True); Over_Level : Over_Data := (others => True); begin for Level in Authentication_Level'Range loop if Connection.Auth (Level).Requested then Counter (Level) := Counter (Level) - 1; Over_Level (Level) := Counter (Level) = 0; end if; end loop; Over := Over_Level = Is_Over; end Decrement_Authentication_Attempt; ---------------- -- Disconnect -- ---------------- procedure Disconnect (Connection : in out HTTP_Connection) is use type Net.Socket_Access; begin if Connection.Opened then if Connection.HTTP_Version = HTTPv2 and then Connection.Socket /= null then -- Properly close the connection declare GoAway : constant HTTP2.Frame.GoAway.Object := HTTP2.Frame.GoAway.Create (Connection.H2_Stream_Id, HTTP2.C_No_Error); begin GoAway.Send (Connection.Socket.all); exception when Net.Socket_Error => -- Be ready that socket already closed null; end; end if; Connection.Opened := False; Connection.Disconnect_Counter := Connection.Disconnect_Counter + 1; if Connection.Socket /= null then Connection.Socket.Shutdown; end if; end if; if Connection.Socket /= null then Net.Free (Connection.Socket); end if; end Disconnect; ------------------ -- Get_H2_Frame -- ------------------ procedure Get_H2_Frame (Connection : in out HTTP_Connection; Ctx : in out Server.Context.Object; Stream : in out HTTP2.Stream.Object; Result : out Response.Data) is use AWS.HTTP2; Frame : constant HTTP2.Frame.Object'Class := HTTP2.Frame.Read (Connection.Socket.all, Ctx.Settings.all); Answers : HTTP2.Frame.List.Object; Error : Error_Codes := C_No_Error; Add_FC : Integer := 0; begin Response.Set.Mode (Result, Response.No_Data); if Frame.Stream_Id = 0 then case Frame.Kind is when HTTP2.Frame.K_GoAway => declare G : constant HTTP2.Frame.GoAway.Object := HTTP2.Frame.GoAway.Object (Frame); begin if G.Error /= C_No_Error then -- We map all HTTP/2 GoAway to HTTP/1 code if present if G.Has_Data and then G.Has_Code_Message then Result := Response.Build (Status_Code => G.Code, Content_Type => "text/plain", Message_Body => G.Message); else Result := Response.Build (Status_Code => Messages.S500, Content_Type => "text/plain", Message_Body => (if G.Has_Data then G.Data else "")); end if; end if; end; when others => Ctx.Settings.Handle_Control_Frame (Frame, Answers, Add_FC, Error); if Add_FC /= 0 and then HTTP2.Connection.Flow_Control_Window_Valid (Stream.Flow_Control_Window, Add_FC) then Stream.Update_Flow_Control_Window (Add_FC); end if; for A of Answers loop Stream.Send_Frame (A); end loop; end case; else if not Stream.Is_Defined then Stream := HTTP2.Stream.Create (Connection.Socket, Frame.Stream_Id, Ctx.Settings.Initial_Window_Size); if Connection.H2_Stream_Id < Frame.Stream_Id then Connection.H2_Stream_Id := Frame.Stream_Id; end if; end if; pragma Assert (Frame.Stream_Id = Stream.Identifier, Frame.Stream_Id'Img & Stream.Identifier'Img); Stream.Received_Frame (Ctx, Frame, Error); end if; end Get_H2_Frame; --------------------- -- Get_H2_Response -- --------------------- procedure Get_H2_Response (Connection : in out HTTP_Connection; Ctx : in out Server.Context.Object; Stream : in out HTTP2.Stream.Object; Result : out Response.Data) is Keep_Alive : Boolean; begin Connection.Socket.Set_Timeout (Connection.Timeouts.Receive); Response.Set.Clear (Result); Stream := HTTP2.Stream.Undefined; -- Read response frames while not Stream.Is_Message_Ready loop Get_H2_Frame (Connection, Ctx, Stream, Result); exit when not Response.Is_Empty (Result); end loop; if Stream.Is_Message_Ready then -- Set headers into Answer Response.Set.Headers (Result, Stream.Headers); -- Then parse headers Read_Parse_Header (Connection, Result, Keep_Alive); Stream.Append_Body (Result); -- Check encoding declare TE : constant String := Response.Header (Result, Messages.Transfer_Encoding_Token); CT_Len : constant Response.Content_Length_Type := Response.Content_Length (Result); begin if not Messages.With_Body (Response.Status_Code (Result)) then -- 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. Connection.Transfer := Content_Length; Connection.Length := 0; elsif TE = "chunked" then raise Protocol_Error with "chunked encoding is not part of HTTP/2"; elsif CT_Len = Response.Undefined_Length then Connection.Transfer := Until_Close; else Connection.Transfer := Content_Length; Connection.Length := CT_Len; end if; end; if not Connection.Persistent then Disconnect (Connection); end if; end if; end Get_H2_Response; ------------------ -- Get_Response -- ------------------ procedure Get_Response (Connection : in out HTTP_Connection; Result : out Response.Data; Get_Body : Boolean := True) is procedure Disconnect; -- close connection socket Sock : Net.Socket_Type'Class renames Connection.Socket.all; Keep_Alive : Boolean; ---------------- -- Disconnect -- ---------------- procedure Disconnect is begin if not Keep_Alive and then not Connection.Streaming then Disconnect (Connection); end if; end Disconnect; begin Sock.Set_Timeout (Connection.Timeouts.Receive); -- Clear the data in the response Response.Set.Clear (Result); Read_Parse_Header (Connection, Result, Keep_Alive); declare TE : constant String := Response.Header (Result, Messages.Transfer_Encoding_Token); CT_Len : constant Response.Content_Length_Type := Response.Content_Length (Result); begin if not Messages.With_Body (Response.Status_Code (Result)) then -- 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. Connection.Transfer := Content_Length; Connection.Length := 0; elsif TE = "chunked" then -- A chuncked message is written on the stream as list of data -- chunk. Each chunk has the following format: -- -- CRLF -- CRLF -- -- The termination chunk is: -- -- 0 CRLF -- CRLF -- Connection.Transfer := Chunked; Connection.Length := 0; elsif CT_Len = Response.Undefined_Length then Connection.Transfer := Until_Close; else Connection.Transfer := Content_Length; Connection.Length := CT_Len; end if; end; -- If we get an Unauthorized response we want to get the body. This is -- needed as in Digest mode the body will gets read by the next request -- and will raise a protocol error. if Get_Body then Read_Body (Connection, Result, Store => True); Connection.Transfer := None; end if; Disconnect; end Get_Response; ------------------ -- Get_Settings -- ------------------ function Get_Settings (Config : AWS.Config.Object) return HTTP2.Frame.Settings.Set is use all type HTTP2.Frame.Settings.Settings_Kind; subtype Byte_4 is HTTP2.Byte_4; begin return HTTP2.Frame.Settings.Set' (1 => (HEADER_TABLE_SIZE, Byte_4 (Config.HTTP2_Header_Table_Size)), 2 => (ENABLE_PUSH, 0), 3 => (MAX_CONCURRENT_STREAMS, Byte_4 (Config.HTTP2_Max_Concurrent_Streams)), 4 => (INITIAL_WINDOW_SIZE, Byte_4 (Config.HTTP2_Initial_Window_Size)), 5 => (MAX_FRAME_SIZE, Byte_4 (Config.HTTP2_Max_Frame_Size)), 6 => (MAX_HEADER_LIST_SIZE, Byte_4 (Config.HTTP2_Max_Header_List_Size))); end Get_Settings; ----------------------- -- Handle_H2_Request -- ----------------------- procedure Handle_H2_Request (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Stream_Element_Array; Auth_Attempts : in out Auth_Attempts_Count; Auth_Is_Over : out Boolean) is Request : HTTP2.Message.Object; Stream : HTTP2.Stream.Object; Ctx : Server.Context.Object (null, 1, Connection.Enc_Table'Access, Connection.Dec_Table'Access, Connection.H2_Connection'Access); begin -- Create the request HTTP/2 message out of Status.Data if Data'Length > 0 then Set_Header (Connection.F_Headers, Messages.Content_Length_Token, Utils.Image (Stream_Element_Offset'(Data'Length))); end if; if not Connection.H2_Preface_Sent then -- Update H_Connection with server settings Send_H2_Connection_Preface (Connection); end if; -- Create frames and send them Stream := HTTP2.Stream.Create (Connection.Socket, Connection.H2_Stream_Id, Ctx.Settings.Initial_Window_Size); Next_Stream_Id (Connection); Request := HTTP2.Message.Create (Connection.F_Headers, Data, Stream.Identifier); Send_H2_Request (Connection, Ctx, Stream, Request); -- Get response Get_H2_Response (Connection, Ctx, Stream, Result); Decrement_Authentication_Attempt (Connection, Auth_Attempts, Auth_Is_Over); end Handle_H2_Request; ----------- -- Image -- ----------- function Image (Data_Range : Content_Range) return String is Result : Unbounded_String; begin Append (Result, "bytes="); if Data_Range.First /= Undefined then Append (Result, Utils.Image (Stream_Element_Offset (Data_Range.First))); end if; Append (Result, "-"); if Data_Range.Last /= Undefined then Append (Result, Utils.Image (Stream_Element_Offset (Data_Range.Last))); end if; return To_String (Result); end Image; ------------------- -- Internal_Post -- ------------------- procedure Internal_Post (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Stream_Element_Array; URI : String; SOAPAction : String; Content_Type : String; Attachments : Attachment_List; Headers : Header_List := Empty_Header_List) is use type AWS.Attachments.List; begin if Attachments = AWS.Attachments.Empty_List then Internal_Post_Without_Attachment (Connection => Connection, Result => Result, Data => Data, URI => URI, SOAPAction => SOAPAction, Content_Type => Content_Type, Headers => Headers); else Internal_Post_With_Attachment (Connection => Connection, Result => Result, Data => Data, URI => URI, SOAPAction => SOAPAction, Content_Type => Content_Type, Attachments => Attachments, Headers => Headers); end if; end Internal_Post; ----------------------------------- -- Internal_Post_With_Attachment -- ----------------------------------- procedure Internal_Post_With_Attachment (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Stream_Element_Array; URI : String; SOAPAction : String; Content_Type : String; Attachments : Attachment_List; Headers : Header_List := Empty_Header_List) is begin if Connection.HTTP_Version = HTTPv1 then Internal_Post_With_Attachment_1 (Connection, Result, Data, URI, SOAPAction, Content_Type, Attachments, Headers); else Internal_Post_With_Attachment_2 (Connection, Result, Data, URI, SOAPAction, Content_Type, Attachments, Headers); end if; end Internal_Post_With_Attachment; ------------------------------------- -- Internal_Post_With_Attachment_1 -- ------------------------------------- procedure Internal_Post_With_Attachment_1 (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Stream_Element_Array; URI : String; SOAPAction : String; Content_Type : String; Attachments : Attachment_List; Headers : Header_List := Empty_Header_List) is use Real_Time; Stamp : constant Time := Clock; Pref_Suf : constant String := "--"; Boundary : constant String := "AWS_Attachment-" & Utils.Random_String (8); Root_Content_Id : constant String := ""; Root_Part_Header : AWS.Headers.List; Try_Count : Natural := Connection.Retry; Auth_Attempts : Auth_Attempts_Count := (others => 2); Auth_Is_Over : Boolean; procedure Build_Root_Part_Header; -- Builds the rootpart header and calculates its size function Content_Length return Stream_Element_Offset; -- Returns the total message content length ---------------------------- -- Build_Root_Part_Header -- ---------------------------- procedure Build_Root_Part_Header is begin Root_Part_Header.Add (Name => AWS.Messages.Content_Type_Token, Value => Content_Type); Root_Part_Header.Add (Name => AWS.Messages.Content_Id_Token, Value => Root_Content_Id); end Build_Root_Part_Header; -------------------- -- Content_Length -- -------------------- function Content_Length return Stream_Element_Offset is begin return 2 + Boundary'Length + 2 -- Root part boundary + CR+LF + Stream_Element_Offset (AWS.Headers.Length (Root_Part_Header)) + Data'Length -- Root part data length + Stream_Element_Offset (AWS.Attachments.Length (Attachments, Boundary)); end Content_Length; begin Connection.F_Headers.Reset; Build_Root_Part_Header; Retry : loop begin Open_Set_Common_Header (Connection, Messages.Post_Token, URI, Headers); declare Sock : Net.Socket_Type'Class renames Connection.Socket.all; begin -- Send message Content-Type (multipart/related) if Content_Type = "" then Set_Header (Connection.F_Headers, Messages.Content_Type_Token, MIME.Multipart_Related & "; type=" & Content_Type & "; start=""" & Root_Content_Id & '"' & "; boundary=""" & Boundary & '"'); else Set_Header (Connection.F_Headers, Messages.Content_Type_Token, MIME.Multipart_Form_Data & "; boundary=""" & Boundary & '"'); end if; if SOAPAction /= Client.No_Data then -- SOAP header Set_Header (Connection.F_Headers, Messages.SOAPAction_Token, SOAPAction); end if; -- Send message Content-Length Set_Header (Connection.F_Headers, Messages.Content_Length_Token, Utils.Image (Content_Length)); AWS.Headers.Send_Header (Sock, Connection.F_Headers, End_Block => True); -- Send multipart message start boundary Net.Buffered.Put_Line (Sock, Pref_Suf & Boundary); -- Send root part header AWS.Headers.Send_Header (Sock, Root_Part_Header, End_Block => True); -- Send root part data if Data'Length /= 0 then Net.Buffered.Write (Sock, Data); Net.Buffered.New_Line (Sock); end if; -- Send the attachments AWS.Attachments.Send (Sock, Attachments, Boundary); Net.Buffered.Put_Line (Sock, Pref_Suf & Boundary & Pref_Suf); end; -- Get answer from server Get_Response (Connection, Result, Get_Body => not Connection.Streaming); Decrement_Authentication_Attempt (Connection, Auth_Attempts, Auth_Is_Over); if Auth_Is_Over then return; elsif Connection.Streaming then Read_Body (Connection, Result, Store => False); end if; exception when E : Net.Socket_Error | Connection_Error => Error_Processing (Connection, Try_Count, Result, "UPLOAD", E, Stamp); exit Retry when not Response.Is_Empty (Result); end; end loop Retry; end Internal_Post_With_Attachment_1; ------------------------------------- -- Internal_Post_With_Attachment_2 -- ------------------------------------- procedure Internal_Post_With_Attachment_2 (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Stream_Element_Array; URI : String; SOAPAction : String; Content_Type : String; Attachments : Attachment_List; Headers : Header_List := Empty_Header_List) is use Real_Time; Stamp : constant Time := Clock; Pref_Suf : constant String := "--"; Boundary : constant String := "AWS_Attachment-" & Utils.Random_String (8); Root_Content_Id : constant String := ""; Root_Part_Header : AWS.Headers.List; Request : HTTP2.Message.Object; Try_Count : Natural := Connection.Retry; Auth_Attempts : Auth_Attempts_Count := (others => 2); Auth_Is_Over : Boolean; Stream : HTTP2.Stream.Object; Ctx : Server.Context.Object (null, 1, Connection.Enc_Table'Access, Connection.Dec_Table'Access, Connection.H2_Connection'Access); procedure Build_Root_Part_Header; -- Builds the rootpart header and calculates its size ---------------------------- -- Build_Root_Part_Header -- ---------------------------- procedure Build_Root_Part_Header is begin Root_Part_Header.Add (Name => Messages.Content_Type_Token, Value => Content_Type); Root_Part_Header.Add (Name => Messages.Content_Id_Token, Value => Root_Content_Id); end Build_Root_Part_Header; begin Connection.F_Headers.Reset; Build_Root_Part_Header; Retry : loop begin Set_Common_Post (Connection, Data, URI, SOAPAction, "", Headers); if Content_Type = "" then Set_Header (Connection.F_Headers, Messages.Content_Type_Token, MIME.Multipart_Related & "; type=" & Content_Type & "; start=""" & Root_Content_Id & '"' & "; boundary=""" & Boundary & '"'); else Set_Header (Connection.F_Headers, Messages.Content_Type_Token, MIME.Multipart_Form_Data & "; boundary=""" & Boundary & '"'); end if; if not Connection.H2_Preface_Sent then -- Update H_Connection with server settings Send_H2_Connection_Preface (Connection); end if; -- Create frames and send them Stream := HTTP2.Stream.Create (Connection.Socket, Connection.H2_Stream_Id, Ctx.Settings.Initial_Window_Size); Next_Stream_Id (Connection); Request := HTTP2.Message.Create (Connection.F_Headers, Stream_Element_Array'(1 .. 0 => <>), Stream.Identifier); -- Append data & attachments Request.Append_Body (Pref_Suf & Boundary & CRLF); declare procedure Write (Data : String); procedure Write (Data : Stream_Element_Array); ----------- -- Write -- ----------- procedure Write (Data : String) is begin Request.Append_Body (Data); end Write; procedure Write (Data : Stream_Element_Array) is begin Request.Append_Body (Data); end Write; procedure Append_Attachments is new AWS.Attachments.Get_Content (Write); procedure Append_Header is new AWS.Headers.Get_Content (Write); begin -- Root part header Append_Header (Root_Part_Header, End_Block => True); -- Data if Data'Length /= 0 then Write (Data); Write (CRLF); end if; -- Attachments Append_Attachments (Attachments, Boundary); end; Request.Append_Body (Pref_Suf & Boundary & Pref_Suf & CRLF); Send_H2_Request (Connection, Ctx, Stream, Request); -- Get response Get_H2_Response (Connection, Ctx, Stream, Result); Decrement_Authentication_Attempt (Connection, Auth_Attempts, Auth_Is_Over); exit Retry when Auth_Is_Over; exception when E : Net.Socket_Error | Connection_Error | HTTP2.Protocol_Error => Error_Processing (Connection, Try_Count, Result, "UPLOAD", E, Stamp); exit Retry when not Response.Is_Empty (Result); end; end loop Retry; end Internal_Post_With_Attachment_2; -------------------------------------- -- Internal_Post_Without_Attachment -- -------------------------------------- procedure Internal_Post_Without_Attachment (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Stream_Element_Array; URI : String; SOAPAction : String; Content_Type : String; Headers : Header_List := Empty_Header_List) is begin if Connection.HTTP_Version = HTTPv1 then Internal_Post_Without_Attachment_1 (Connection, Result, Data, URI, SOAPAction, Content_Type, Headers); else Internal_Post_Without_Attachment_2 (Connection, Result, Data, URI, SOAPAction, Content_Type, Headers); end if; end Internal_Post_Without_Attachment; ---------------------------------------- -- Internal_Post_Without_Attachment_1 -- ---------------------------------------- procedure Internal_Post_Without_Attachment_1 (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Stream_Element_Array; URI : String; SOAPAction : String; Content_Type : String; Headers : Header_List := Empty_Header_List) is use Real_Time; Stamp : constant Time := Clock; Try_Count : Natural := Connection.Retry; Auth_Attempts : Auth_Attempts_Count := (others => 2); Auth_Is_Over : Boolean; begin Connection.F_Headers.Reset; Retry : loop begin -- Post Data with headers Set_Common_Post (Connection, Data, URI, SOAPAction, Content_Type, Headers); AWS.Headers.Send_Header (Connection.Socket.all, Connection.F_Headers, End_Block => True); -- Send message body Net.Buffered.Write (Connection.Socket.all, Data); -- Get answer from server Get_Response (Connection, Result, Get_Body => not Connection.Streaming); Decrement_Authentication_Attempt (Connection, Auth_Attempts, Auth_Is_Over); if Auth_Is_Over then return; elsif Connection.Streaming then Read_Body (Connection, Result, Store => False); end if; exception when E : Net.Socket_Error | Connection_Error => Error_Processing (Connection, Try_Count, Result, "POST", E, Stamp); exit Retry when not Response.Is_Empty (Result); end; end loop Retry; end Internal_Post_Without_Attachment_1; ---------------------------------------- -- Internal_Post_Without_Attachment_2 -- ---------------------------------------- procedure Internal_Post_Without_Attachment_2 (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Stream_Element_Array; URI : String; SOAPAction : String; Content_Type : String; Headers : Header_List := Empty_Header_List) is use Ada.Real_Time; Stamp : constant Time := Clock; Try_Count : Natural := Connection.Retry; Auth_Attempts : Auth_Attempts_Count := (others => 2); Auth_Is_Over : Boolean; begin Connection.F_Headers.Reset; Retry : loop begin Set_Common_Post (Connection, Data, URI, SOAPAction, Content_Type, Headers); Handle_H2_Request (Connection, Result, Data, Auth_Attempts, Auth_Is_Over); exit Retry when Auth_Is_Over; exception when E : Net.Socket_Error | Connection_Error | HTTP2.Protocol_Error => Error_Processing (Connection, Try_Count, Result, "POST", E, Stamp); exit Retry when not Response.Is_Empty (Result); end; end loop Retry; end Internal_Post_Without_Attachment_2; --------------------- -- Internal_Upload -- --------------------- procedure Internal_Upload (Connection : in out HTTP_Connection; Result : out Response.Data; Filename : String; URI : String; Headers : Header_List := Empty_Header_List; Progress : access procedure (Total, Sent : Stream_Element_Offset) := null) is begin if Connection.HTTP_Version = HTTPv1 then Internal_Upload_1 (Connection, Result, Filename, URI, Headers, Progress); else Internal_Upload_2 (Connection, Result, Filename, URI, Headers, Progress); end if; end Internal_Upload; ----------------------- -- Internal_Upload_1 -- ----------------------- procedure Internal_Upload_1 (Connection : in out HTTP_Connection; Result : out Response.Data; Filename : String; URI : String; Headers : Header_List := Empty_Header_List; Progress : access procedure (Total, Sent : Stream_Element_Offset) := null) is use Ada.Real_Time; Stamp : constant Time := Clock; Pref_Suf : constant String := "--"; Boundary : constant String := "AWS_File_Upload-" & Utils.Random_String (8); CT : constant String := Messages.Content_Type (MIME.Content_Type (Filename)); CD : constant String := Messages.Content_Disposition ("form-data", "filename", URL.Encode (Filename)); File_Size : constant Stream_Element_Offset := Stream_Element_Offset (Utils.File_Size (Filename)); Try_Count : Natural := Connection.Retry; Auth_Attempts : Auth_Attempts_Count := (others => 2); Auth_Is_Over : Boolean; function Content_Length return Stream_Element_Offset; -- Returns the total message content length procedure Send_File; -- Send file content to the server -------------------- -- Content_Length -- -------------------- function Content_Length return Stream_Element_Offset is begin return 2 * Boundary'Length -- 2 boundaries + 4 -- two boundaries start with "--" + 2 -- second one ends with "--" + 10 -- 5 lines with CR+LF + CT'Length -- content type header + CD'Length -- content disposition header + File_Size + 2; -- CR+LF after file data end Content_Length; --------------- -- Send_File -- --------------- procedure Send_File is Sock : Net.Socket_Type'Class renames Connection.Socket.all; Buffer : Stream_Element_Array (1 .. 4_096); Last : Stream_Element_Offset; File : Stream_IO.File_Type; Sent : Stream_Element_Offset := 0; begin -- Send multipart message start boundary Net.Buffered.Put_Line (Sock, Pref_Suf & Boundary); -- Send Content-Disposition header Net.Buffered.Put_Line (Sock, CD); -- Send Content-Type: header Net.Buffered.Put_Line (Sock, CT); Net.Buffered.New_Line (Sock); -- Send file content Stream_IO.Open (File, Stream_IO.In_File, Filename); while not Stream_IO.End_Of_File (File) loop Stream_IO.Read (File, Buffer, Last); Net.Buffered.Write (Sock, Buffer (1 .. Last)); if Progress /= null then Sent := Sent + Last; Progress (File_Size, Sent); end if; end loop; Stream_IO.Close (File); Net.Buffered.New_Line (Sock); -- Send multipart message end boundary Net.Buffered.Put_Line (Sock, Pref_Suf & Boundary & Pref_Suf); exception when Net.Socket_Error => -- Properly close the file if needed if Stream_IO.Is_Open (File) then Stream_IO.Close (File); end if; raise; end Send_File; begin Retry : loop begin Open_Set_Common_Header (Connection, "POST", URI, Headers); declare Sock : Net.Socket_Type'Class renames Connection.Socket.all; begin -- Send message Content-Type (Multipart/form-data) Set_Header (Connection.F_Headers, Messages.Content_Type_Token, MIME.Multipart_Form_Data & "; boundary=""" & Boundary & '"'); -- Send message Content-Length Set_Header (Connection.F_Headers, Messages.Content_Length_Token, Utils.Image (Content_Length)); AWS.Headers.Send_Header (Sock, Connection.F_Headers, End_Block => True); -- Send message body Send_File; end; -- Get answer from server Get_Response (Connection, Result, Get_Body => not Connection.Streaming); Decrement_Authentication_Attempt (Connection, Auth_Attempts, Auth_Is_Over); if Auth_Is_Over then return; elsif Connection.Streaming then Read_Body (Connection, Result, Store => False); end if; exception when E : Net.Socket_Error | Connection_Error => Error_Processing (Connection, Try_Count, Result, "Upload", E, Stamp); exit Retry when not Response.Is_Empty (Result); end; end loop Retry; end Internal_Upload_1; ----------------------- -- Internal_Upload_2 -- ----------------------- procedure Internal_Upload_2 (Connection : in out HTTP_Connection; Result : out Response.Data; Filename : String; URI : String; Headers : Header_List := Empty_Header_List; Progress : access procedure (Total, Sent : Stream_Element_Offset) := null) is use Ada.Real_Time; CT : constant String := Messages.Content_Type (MIME.Content_Type (Filename)); CD : constant String := Messages.Content_Disposition ("form-data", "filename", URL.Encode (Filename)); Stamp : constant Time := Clock; Pref_Suf : constant String := "--"; Boundary : constant String := "AWS_Attachment-" & Utils.Random_String (8); Request : HTTP2.Message.Object; Try_Count : Natural := Connection.Retry; Auth_Attempts : Auth_Attempts_Count := (others => 2); Auth_Is_Over : Boolean; Stream : HTTP2.Stream.Object; Ctx : Server.Context.Object (null, 1, Connection.Enc_Table'Access, Connection.Dec_Table'Access, Connection.H2_Connection'Access); begin Connection.F_Headers.Reset; Retry : loop begin Open_Set_Common_Header (Connection, Messages.Post_Token, URI, Headers); Set_Header (Connection.F_Headers, Messages.Content_Type_Token, MIME.Multipart_Form_Data & "; boundary=""" & Boundary & '"'); if not Connection.H2_Preface_Sent then -- Update H_Connection with server settings Send_H2_Connection_Preface (Connection); end if; -- Create frames and send them Stream := HTTP2.Stream.Create (Connection.Socket, Connection.H2_Stream_Id, Ctx.Settings.Initial_Window_Size); Next_Stream_Id (Connection); Request := HTTP2.Message.Create (Connection.F_Headers, Stream_Element_Array'(1 .. 0 => <>), Stream.Identifier); -- Append file content Request.Append_Body (Pref_Suf & Boundary & CRLF); declare procedure Write (Data : String); procedure Write (Data : Stream_Element_Array; Next_Size : in out Stream_Element_Count); Total : constant Stream_Element_Offset := Stream_Element_Offset (Resources.Files.File_Size (Filename)); Sent : Stream_Element_Offset := 0; ----------- -- Write -- ----------- procedure Write (Data : String) is begin Request.Append_Body (Data); end Write; procedure Write (Data : Stream_Element_Array; Next_Size : in out Stream_Element_Count) is pragma Unreferenced (Next_Size); begin Request.Append_Body (Data); Sent := Sent + Data'Length; if Progress /= null then Progress (Total, Sent); end if; end Write; procedure Send_File is new AWS.Server.HTTP_Utils.Send_File_G (Write); Length : Resources.Content_Length_Type := 0; File : Resources.File_Type; begin -- Append part headers Write (CD & CRLF); Write (CT & CRLF); Write (CRLF); Resources.Files.Open (File, Filename); Send_File (null, 1, File, 1, Chunk_Size => 4 * 1024, Length => Length); Resources.Close (File); Write (CRLF); end; Request.Append_Body (Pref_Suf & Boundary & Pref_Suf & CRLF); Send_H2_Request (Connection, Ctx, Stream, Request); -- Get response Get_H2_Response (Connection, Ctx, Stream, Result); Decrement_Authentication_Attempt (Connection, Auth_Attempts, Auth_Is_Over); exit Retry when Auth_Is_Over; exception when E : Net.Socket_Error | Connection_Error | HTTP2.Protocol_Error => Error_Processing (Connection, Try_Count, Result, "Upload", E, Stamp); exit Retry when not Response.Is_Empty (Result); end; end loop Retry; end Internal_Upload_2; -------------------- -- Next_Stream_Id -- -------------------- procedure Next_Stream_Id (Connection : in out HTTP_Connection) is use type AWS.HTTP2.Stream_Id; begin Connection.H2_Stream_Id := Connection.H2_Stream_Id + 2; end Next_Stream_Id; ---------------------------- -- Open_Set_Common_Header -- ---------------------------- procedure Open_Set_Common_Header (Connection : in out HTTP_Connection; Method : String; URI : String; Headers : Header_List := Empty_Header_List) is Is_H2 : constant Boolean := Connection.HTTP_Version = HTTPv2; Sock : Net.Socket_Access := Connection.Socket; No_Data : Unbounded_String renames Null_Unbounded_String; function Persistence return String with Inline; -- Returns "Keep-Alive" is we have a persistent connection and "Close" -- otherwise. function Encoded_URI return String is (Strings.Fixed.Translate (URI, Strings.Maps.To_Mapping (" ", "+"))); -- Returns URI encoded (' ' -> '+') ----------------- -- Persistence -- ----------------- function Persistence return String is begin if Connection.Persistent then return "Keep-Alive"; else return "Close"; end if; end Persistence; Host_Address : constant String := AWS.URL.Host (Connection.Host_URL, IPv6_Brackets => True) & AWS.URL.Port_Not_Default (Connection.Host_URL); begin -- Open connection if needed if not Connection.Opened then Connect (Connection); Sock := Connection.Socket; end if; Sock.Set_Timeout (Connection.Timeouts.Send); -- First the the method (request) line if Is_H2 then Set_Header (Connection.F_Headers, Messages.Method_Token, Method); Set_Header (Connection.F_Headers, Messages.Scheme_Token, AWS.URL.Protocol_Name (Connection.Connect_URL)); end if; if Connection.Proxy = No_Data or else AWS.URL.Security (Connection.Host_URL) then -- Without proxy or over proxy tunneling. -- In both cases we want to send the pathname only, we are not -- required to send the absolute path. if URI = "" then if Is_H2 then Set_Header (Connection.F_Headers, Messages.Path2_Token, AWS.URL.Pathname_And_Parameters (Connection.Host_URL)); else Set_Header (Connection.F_Headers, Method, AWS.URL.Pathname_And_Parameters (Connection.Host_URL) & ' ' & AWS.HTTP_Version); end if; else if Is_H2 then Set_Header (Connection.F_Headers, Messages.Path2_Token, Encoded_URI); else Set_Header (Connection.F_Headers, Method, Encoded_URI & ' ' & AWS.HTTP_Version); end if; end if; else -- We have a proxy configured, in thoses case we want to send the -- absolute path and parameters. if URI = "" then if Is_H2 then Set_Header (Connection.F_Headers, Messages.Path2_Token, AWS.URL.URL (Connection.Host_URL)); else Set_Header (Connection.F_Headers, Method, AWS.URL.URL (Connection.Host_URL) & ' ' & AWS.HTTP_Version); end if; else -- Send GET http://[:port]/URI HTTP/1.1 if Is_H2 then Set_Header (Connection.F_Headers, Messages.Path2_Token, URL.Protocol_Name (Connection.Host_URL) & "://" & Host_Address & Encoded_URI); else Set_Header (Connection.F_Headers, Method, URL.Protocol_Name (Connection.Host_URL) & "://" & Host_Address & Encoded_URI & ' ' & AWS.HTTP_Version); end if; end if; end if; Connection.F_Headers.Union (Headers, Unique => True); Connection.F_Headers.Union (Connection.C_Headers, Unique => True); -- Header command if Connection.Proxy = No_Data or else AWS.URL.Security (Connection.Host_URL) then -- Unless Header already contains connection info (like would be -- the case for web sockets for instance) if not Is_H2 and then not Connection.F_Headers.Exist (Messages.Connection_Token) then Set_Header (Connection.F_Headers, Messages.Connection_Token, Persistence); end if; else if not Is_H2 then Set_Header (Connection.F_Headers, Messages.Proxy_Connection_Token, Persistence); end if; -- Proxy Authentication Set_Authentication_Header (Connection, Messages.Proxy_Authorization_Token, Connection.Auth (Proxy), URI, Method); end if; -- Cookie if Connection.Cookie /= No_Data then Set_Header (Connection.F_Headers, Messages.Cookie_Token, To_String (Connection.Cookie)); end if; Set_Header (Connection.F_Headers, Messages.Host_Token, Host_Address); Set_Header (Connection.F_Headers, Messages.Accept_Token, "text/html, */*"); Set_Header (Connection.F_Headers, Messages.Accept_Encoding_Token, "gzip, deflate"); Set_Header (Connection.F_Headers, Messages.Accept_Language_Token, "fr, ru, us"); if Connection.User_Agent /= Null_Unbounded_String then Set_Header (Connection.F_Headers, Messages.User_Agent_Token, To_String (Connection.User_Agent)); end if; if Connection.Data_Range /= No_Range then Set_Header (Connection.F_Headers, Messages.Range_Token, Image (Connection.Data_Range)); end if; -- User Authentication Set_Authentication_Header (Connection, Messages.Authorization_Token, Connection.Auth (WWW), URI, Method); end Open_Set_Common_Header; --------------- -- Read_Body -- --------------- procedure Read_Body (Connection : in out HTTP_Connection; Result : out Response.Data; Store : Boolean) is use Ada.Real_Time; Expire : constant Time := Clock + Connection.Timeouts.Response; begin loop declare Buffer : Stream_Element_Array (1 .. 8192); Last : Stream_Element_Offset; begin Read_Some (Connection, Buffer, Last); exit when Last < Buffer'First; if Store then Response.Set.Append_Body (Result, Buffer (Buffer'First .. Last)); end if; end; if Clock > Expire then if Store then Response.Set.Append_Body (Result, "..." & ASCII.LF & " Response Timeout"); end if; Response.Set.Status_Code (Result, Messages.S408); exit; end if; end loop; end Read_Body; ----------------------- -- Read_Parse_Header -- ----------------------- procedure Read_Parse_Header (Connection : in out HTTP_Connection; Answer : in out Response.Data; Keep_Alive : out Boolean) is procedure Parse_Authenticate_Line (Level : Authentication_Level; Auth_Line : String); -- Parses Authentication request line and fill Connection.Auth (Level) -- field with the information read on the line. Handle WWW and Proxy -- authentication. procedure Read_Status_Line with Pre => Connection.HTTP_Version = HTTPv1; -- Read the status line procedure Set_Keep_Alive (Data : String); -- Set the Parse_Header.Keep_Alive depending on data from the -- Proxy-Connection or Connection header line. function "+" (S : String) return Unbounded_String renames To_Unbounded_String; Sock : Net.Socket_Type'Class renames Connection.Socket.all; Status : Messages.Status_Code; Request_Auth_Mode : array (Authentication_Level) of Authentication_Mode := (others => Any); ----------------------------- -- Parse_Authenticate_Line -- ----------------------------- procedure Parse_Authenticate_Line (Level : Authentication_Level; Auth_Line : String) is use Ada.Characters.Handling; Basic_Token : constant String := "BASIC"; Digest_Token : constant String := "DIGEST"; Auth : Authentication_Type renames Connection.Auth (Level); Request_Mode : Authentication_Mode; Read_Params : Boolean := False; -- Set it to true when the authentication mode is stronger -- then before. procedure Value (Item : String; Quit : in out Boolean); -- Routine receiving unnamed value during parsing of -- authentication line. procedure Named_Value (Name : String; Value : String; Quit : in out Boolean); -- Routine receiving name/value pairs during parsing of -- authentication line. ----------------- -- Named_Value -- ----------------- procedure Named_Value (Name : String; Value : String; Quit : in out Boolean) is pragma Warnings (Off, Quit); U_Name : constant String := To_Upper (Name); begin if not Read_Params then return; end if; if U_Name = "REALM" then Auth.Realm := +Value; elsif U_Name = "NONCE" then Auth.Nonce := +Value; elsif U_Name = "QOP" then Auth.QOP := +Value; elsif U_Name = "ALGORITHM" then if Value /= "MD5" then raise Constraint_Error with "Only MD5 algorithm is supported."; end if; -- The parameter Stale is true when the Digest value is correct -- but the nonce value is too old or incorrect. -- -- This mean that an interactive HTTP client should not ask -- name/password from the user, and try to use name/password from -- the previous successful authentication attempt. -- We do not need to check Stale authentication parameter -- for now, because our client is not interactive, so we are not -- going to ask user to input the name/password anyway. We could -- uncomment it later, when we would provide some interactive -- behavior to AWS.Client or interface to the interactive -- programs by callback to the AWS.Client. -- -- elsif U_Name = "STALE" then -- null; end if; end Named_Value; ----------- -- Value -- ----------- procedure Value (Item : String; Quit : in out Boolean) is pragma Warnings (Off, Quit); Mode_Image : constant String := To_Upper (Item); begin if Mode_Image = Digest_Token then Request_Mode := Digest; elsif Mode_Image = Basic_Token then Request_Mode := Basic; else Request_Mode := Unknown; end if; Read_Params := Request_Mode > Request_Auth_Mode (Level); if Read_Params then Request_Auth_Mode (Level) := Request_Mode; Auth.Requested := True; Auth.Work_Mode := Request_Mode; Auth.NC := 0; end if; end Value; ----------- -- Parse -- ----------- procedure Parse is new Headers.Values.Parse (Value, Named_Value); begin Parse (Auth_Line); end Parse_Authenticate_Line; ----------------------- -- Read_Status_Line -- ----------------------- procedure Read_Status_Line is function Get_Full_Line return String; -- Returns a full HTTP line (handle continuation line) -- -- ??? This is non-standard and as been implemented because some -- Lotus Domino servers do send a Reason-Phrase with continuation -- line. This is clearly not valid see [RFC 2616 - 6.1]. ------------------- -- Get_Full_Line -- ------------------- function Get_Full_Line return String is Line : constant String := Net.Buffered.Get_Line (Sock); N_Char : constant Character := Net.Buffered.Peek_Char (Sock); begin if N_Char = ' ' or else N_Char = ASCII.HT then -- Next line is a continuation line [RFC 2616 - 2.2], but -- again this is non standard here, see comment above. return Line & Get_Full_Line; else return Line; end if; end Get_Full_Line; Line : constant String := Get_Full_Line; begin Debug_Message ("< ", Line); -- Checking the first line in the HTTP header. -- It must match Messages.HTTP_Token. if Utils.Match (Line, Messages.HTTP_Token) then Status := Messages.Status_Code'Value ('S' & Line (Messages.HTTP_Token'Length + Line'First + 4 .. Messages.HTTP_Token'Length + Line'First + 6)); Response.Set.Status_Code (Answer, Status); -- By default HTTP/1.0 connection is not keep-alive but -- HTTP/1.1 is keep-alive. Keep_Alive := Line (Messages.HTTP_Token'Length + Line'First .. Messages.HTTP_Token'Length + Line'First + 2) >= "1.1"; else -- or else it is wrong answer from server raise Protocol_Error with Line; end if; end Read_Status_Line; -------------------- -- Set_Keep_Alive -- -------------------- procedure Set_Keep_Alive (Data : String) is begin if Utils.Match (Data, "Close") then Keep_Alive := False; elsif Utils.Match (Data, "Keep-Alive") then Keep_Alive := True; end if; end Set_Keep_Alive; use type Messages.Status_Code; function Get_Content_Encoding return String is (Characters.Handling.To_Lower (Response.Header (Answer, Messages.Content_Encoding_Token))); begin -- Reset authentication information for Level in Authentication_Level'Range loop Connection.Auth (Level).Requested := False; end loop; -- By default we have at least some headers. This value will be -- updated if a message body is read. Response.Set.Mode (Answer, Response.Header); -- Read headers from server's answer only in HTTP/1.x mode if Connection.HTTP_Version = HTTPv1 then Read_Status_Line; Response.Set.Read_Header (Sock, Answer); Response.Set.Parse_Header (Answer); declare procedure Decode_Init (Z_Header : ZLib.Header_Type); ----------------- -- Decode_Init -- ----------------- procedure Decode_Init (Z_Header : ZLib.Header_Type) is use type Utils.Stream_Element_Array_Access; begin ZLib.Inflate_Init (Connection.Decode_Filter, Header => Z_Header); if Connection.Decode_Buffer = null then Connection.Decode_Buffer := new Stream_Element_Array (1 .. 8096); end if; Connection.Decode_First := Connection.Decode_Buffer'Last + 1; Connection.Decode_Last := Connection.Decode_Buffer'Last; end Decode_Init; Content_Encoding : constant String := Get_Content_Encoding; begin if ZLib.Is_Open (Connection.Decode_Filter) then ZLib.Close (Connection.Decode_Filter, Ignore_Error => True); end if; if Content_Encoding = "gzip" then Decode_Init (ZLib.GZip); elsif Content_Encoding = "deflate" then Decode_Init (ZLib.Default); end if; end; else -- HTTP/2 Response.Header (Answer).Debug_Print; -- In HTTP/2 the status is encoded in :status pseudo header Status := Messages.Status_Code'Value ('S' & Response.Header (Answer, Messages.Status_Token)); Response.Set.Status_Code (Answer, Status); Response.Set.Parse_Header (Answer); declare Content_Encoding : constant String := Get_Content_Encoding; begin if Content_Encoding in "gzip" | "deflate" then Response.Set.Data_Encoding (Answer, Messages.Content_Encoding'Value (Content_Encoding), Direction => Response.Set.Decode); end if; end; end if; -- ??? we should not expect 100 response message after the body sent. -- This code needs to be fixed. -- We should expect 100 status line only before sending the message -- body to server. -- And we should send Expect: header line in the header if we could -- deal with 100 status code. -- See [RFC 2616 - 8.2.3] use of the 100 (Continue) Status. if Connection.HTTP_Version = HTTPv1 and then Status = Messages.S100 then Read_Status_Line; Response.Set.Read_Header (Sock, Answer); Response.Set.Parse_Header (Answer); end if; Set_Keep_Alive (Response.Header (Answer, Messages.Connection_Token)); Set_Keep_Alive (Response.Header (Answer, Messages.Proxy_Connection_Token)); -- Read and store all cookies from response header declare Set_Cookies : constant Headers.VString_Array := Response.Header (Answer).Get_Values (Messages.Set_Cookie_Token); Cookie : Unbounded_String; I : Natural; begin for K in Set_Cookies'Range loop if Set_Cookies (K) /= Null_Unbounded_String then I := Strings.Unbounded.Index (Set_Cookies (K), ";"); if Cookie /= Null_Unbounded_String then Append (Cookie, "; "); end if; -- We found a cookie NAME=VALUE, record it if I = 0 then Append (Cookie, Set_Cookies (K)); else Append (Cookie, Slice (Set_Cookies (K), 1, I - 1)); end if; end if; end loop; -- If we have some value, update the connection status if Cookie /= Null_Unbounded_String then Connection.Cookie := Cookie; end if; end; Parse_Authenticate_Line (WWW, Response.Header (Answer, Messages.WWW_Authenticate_Token)); Parse_Authenticate_Line (Proxy, Response.Header (Answer, Messages.Proxy_Authenticate_Token)); if Debug_On then declare List : constant AWS.Headers.List := Response.Header (Answer); begin for J in 1 .. List.Count loop Debug_Message ("< ", List.Get_Line (J)); end loop; end; end if; end Read_Parse_Header; -------------------------------- -- Send_H2_Connection_Preface -- -------------------------------- procedure Send_H2_Connection_Preface (Connection : in out HTTP_Connection) is use all type HTTP2.Frame.Kind_Type; begin -- Send the HTTP/2 connection preface Net.Buffered.Write (Connection.Socket.all, HTTP2.Client_Connection_Preface); -- Send the setting frame (stream id 0) HTTP2.Frame.Settings.Create (Connection.H2_Settings).Send (Connection.Socket.all); -- We need to read the settings from server declare Frame : constant HTTP2.Frame.Object'Class := HTTP2.Frame.Read (Connection.Socket.all, Connection.H2_Connection); begin if Frame.Kind /= K_Settings then if HTTP2.Debug then Frame.Dump ("UNEXPECTED"); end if; raise Constraint_Error with "server should have answered with a setting frame"; else declare S_Frame : constant HTTP2.Frame.Settings.Object := HTTP2.Frame.Settings.Object (Frame); begin -- Make sure the settings frame is not an aknowledged, this -- should not happen anyway. if not S_Frame.Has_Flag (HTTP2.Frame.Ack_Flag) then HTTP2.Connection.Set (Connection.H2_Connection, HTTP2.Frame.Settings.Values (S_Frame)); end if; end; end if; end; Connection.H2_Preface_Sent := True; end Send_H2_Connection_Preface; --------------------- -- Send_H2_Request -- --------------------- procedure Send_H2_Request (Connection : in out HTTP_Connection; Ctx : in out Server.Context.Object; Stream : in out HTTP2.Stream.Object; Request : in out HTTP2.Message.Object) is use all type HTTP2.Frame.Kind_Type; Result : Response.Data; begin All_Frames : loop for F of Request.To_Frames (Ctx, Stream) loop Stream.Send_Frame (F); if F.Kind = HTTP2.Frame.K_Data then Ctx.Settings.Update_Flow_Control_Window (-Natural (F.Length)); end if; end loop; exit All_Frames when not Request.More_Frames; while Ctx.Settings.Flow_Control_Window <= 0 or else Stream.Flow_Control_Window <= 0 loop Get_H2_Frame (Connection, Ctx, Stream, Result); end loop; end loop All_Frames; end Send_H2_Request; ------------------ -- Send_Request -- ------------------ procedure Send_Request (Connection : in out HTTP_Connection; Kind : Method_Kind; Result : out Response.Data; URI : String; Data : Stream_Element_Array := No_Data; Headers : Header_List := Empty_Header_List) is begin if Connection.HTTP_Version = HTTPv1 then Send_Request_1 (Connection, Kind, Result, URI, Data, Headers); else Send_Request_2 (Connection, Kind, Result, URI, Data, Headers); end if; end Send_Request; -------------------- -- Send_Request_1 -- -------------------- procedure Send_Request_1 (Connection : in out HTTP_Connection; Kind : Method_Kind; Result : out Response.Data; URI : String; Data : Stream_Element_Array := No_Data; Headers : Header_List := Empty_Header_List) is use Ada.Real_Time; Stamp : constant Time := Clock; Try_Count : Natural := Connection.Retry; Auth_Attempts : Auth_Attempts_Count := (others => 2); Auth_Is_Over : Boolean; begin Retry : loop begin Open_Set_Common_Header (Connection, Method_Kind'Image (Kind), URI, Headers); -- Add content length if needed if Data'Length > 0 then Set_Header (Connection.F_Headers, Messages.Content_Length_Token, Utils.Image (Stream_Element_Offset'(Data'Length))); end if; -- Send all headers for this connection AWS.Headers.Send_Header (Connection.Socket.all, Connection.F_Headers, End_Block => True); -- If there is some data to send if Data'Length > 0 then -- Send message body Net.Buffered.Write (Connection.Socket.all, Data); end if; Get_Response (Connection, Result, Get_Body => Kind /= HEAD and then not Connection.Streaming); Decrement_Authentication_Attempt (Connection, Auth_Attempts, Auth_Is_Over); if Auth_Is_Over then return; elsif Kind /= HEAD and then Connection.Streaming then Read_Body (Connection, Result, Store => False); end if; exception when E : Net.Socket_Error | Connection_Error => Error_Processing (Connection, Try_Count, Result, Method_Kind'Image (Kind), E, Stamp); exit Retry when not Response.Is_Empty (Result); end; end loop Retry; end Send_Request_1; -------------------- -- Send_Request_2 -- -------------------- procedure Send_Request_2 (Connection : in out HTTP_Connection; Kind : Method_Kind; Result : out Response.Data; URI : String; Data : Stream_Element_Array := No_Data; Headers : Header_List := Empty_Header_List) is use Ada.Real_Time; Stamp : constant Time := Clock; Try_Count : Natural := Connection.Retry; Auth_Attempts : Auth_Attempts_Count := (others => 2); Auth_Is_Over : Boolean; begin Connection.F_Headers.Reset; Retry : loop begin Open_Set_Common_Header (Connection, Method_Kind'Image (Kind), URI, Headers); Handle_H2_Request (Connection, Result, Data, Auth_Attempts, Auth_Is_Over); exit Retry when Auth_Is_Over; exception when E : Net.Socket_Error | Connection_Error | HTTP2.Protocol_Error => Error_Processing (Connection, Try_Count, Result, Method_Kind'Image (Kind), E, Stamp); exit Retry when not Response.Is_Empty (Result); end; end loop Retry; end Send_Request_2; ------------------------ -- Set_Authentication -- ------------------------ procedure Set_Authentication (Auth : out Authentication_Type; User : String; Pwd : String; Mode : Authentication_Mode) is begin Auth.User := To_Unbounded_String (User); Auth.Pwd := To_Unbounded_String (Pwd); Auth.Init_Mode := Mode; -- The Digest authentication could not be send without -- server authentication request, because client have to have nonce -- value, so in the Digest and Any authentication modes we are not -- setting up Work_Mode to the exact value. -- But for Basic authentication we are sending just username/password, -- and do not need any information from server to do it. -- So if the client want to authenticate "Basic", we are setting up -- Work_Mode right now. if Mode = Basic then Auth.Work_Mode := Basic; end if; end Set_Authentication; ------------------------------- -- Set_Authentication_Header -- ------------------------------- procedure Set_Authentication_Header (Connection : in out HTTP_Connection; Token : String; Data : in out Authentication_Type; URI : String; Method : String) is User : constant String := To_String (Data.User); Pwd : constant String := To_String (Data.Pwd); begin if User /= Client.No_Data and then Pwd /= Client.No_Data then if Data.Work_Mode = Basic then Set_Header (Connection.F_Headers, Token, "Basic " & AWS.Translator.Base64_Encode (User & ':' & Pwd)); elsif Data.Work_Mode = Digest then declare Nonce : constant String := To_String (Data.Nonce); Realm : constant String := To_String (Data.Realm); QOP : constant String := To_String (Data.QOP); function Get_URI return String; -- Returns the real URI where the request is going to be -- sent. It is either Open_Set_Common_Header.URI parameter -- if it exists (without the HTTP parameters part), or URI -- part of the Connection.Connect_URL field. function QOP_Data return String; -- Returns string with qop, cnonce and nc parameters -- if qop parameter exists in the server auth request, -- or empty string if not [RFC 2617 - 3.2.2]. Response : AWS.Digest.Digest_String; ------------- -- Get_URI -- ------------- function Get_URI return String is URI_Last : Natural; begin if URI = "" then return URL.Path (Connection.Connect_URL) & URL.File (Connection.Connect_URL); else URI_Last := Strings.Fixed.Index (URI, "?"); if URI_Last = 0 then URI_Last := URI'Last; else URI_Last := URI_Last - 1; end if; return URI (URI'First .. URI_Last); end if; end Get_URI; URI : constant String := Get_URI; -------------- -- QOP_Data -- -------------- function QOP_Data return String is CNonce : constant AWS.Digest.Nonce := AWS.Digest.Create_Nonce; begin if QOP = Client.No_Data then Response := AWS.Digest.Create (Username => User, Realm => Realm, Password => Pwd, Nonce => Nonce, Method => Method, URI => URI); return ""; else Data.NC := Data.NC + 1; declare NC : constant String := Utils.Hex (Data.NC, 8); begin Response := AWS.Digest.Create (Username => User, Realm => Realm, Password => Pwd, Nonce => Nonce, CNonce => String (CNonce), NC => NC, QOP => QOP, Method => Method, URI => URI); return "qop=""" & QOP & """, cnonce=""" & String (CNonce) & """, nc=" & NC & ", "; end; end if; end QOP_Data; begin Set_Header (Connection.F_Headers, Token, "Digest " & QOP_Data & "nonce=""" & Nonce & """, username=""" & User & """, realm=""" & Realm & """, uri=""" & URI & """, response=""" & Response & """"); end; end if; end if; end Set_Authentication_Header; --------------------- -- Set_Common_Post -- --------------------- procedure Set_Common_Post (Connection : in out HTTP_Connection; Data : Stream_Element_Array; URI : String; SOAPAction : String; Content_Type : String; Headers : Header_List := Empty_Header_List) is Is_H2 : constant Boolean := Connection.HTTP_Version = HTTPv2; begin Open_Set_Common_Header (Connection, Messages.Post_Token, URI, Headers); if Content_Type /= Client.No_Data then Set_Header (Connection.F_Headers, Messages.Content_Type_Token, Content_Type); end if; if SOAPAction /= Client.No_Data then -- SOAP header Set_Header (Connection.F_Headers, Messages.SOAPAction_Token, SOAPAction); end if; -- Send message Content_Length if not Is_H2 then Set_Header (Connection.F_Headers, Messages.Content_Length_Token, Utils.Image (Stream_Element_Offset'(Data'Length))); end if; end Set_Common_Post; ---------------- -- Set_Header -- ---------------- procedure Set_Header (Headers : in out Header_List; Header : String; Value : String := "") is begin if not Headers.Exist (Header) then Headers.Add (Header, Value); Debug_Message ("> ", Header & (if Value = "" then "" else "=" & Value)); end if; end Set_Header; ------------------------- -- Set_HTTP_Connection -- ------------------------- procedure Set_HTTP_Connection (HTTP_Client : in out HTTP_Connection; Sock_Ptr : Net.Socket_Access) is begin HTTP_Client.Socket := Sock_Ptr; HTTP_Client.Opened := True; end Set_HTTP_Connection; ----------- -- Value -- ----------- function Value (V : String) return Unbounded_String is begin if V = Client.No_Data then return Null_Unbounded_String; else return To_Unbounded_String (V); end if; end Value; end AWS.Client.HTTP_Utils;