------------------------------------------------------------------------------ -- Ada Web Server -- -- -- -- Copyright (C) 2005-2018, 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.Strings.Fixed; with AWS.Digest; with AWS.Headers.Values; with AWS.Messages; with AWS.MIME; with AWS.Net.Buffered; with AWS.Net.SSL; with AWS.Response.Set; 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. --------- -- "+" -- --------- 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; 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 Send_Header (Sock.all, "CONNECT " & Host_Address & ' ' & HTTP_Version); Send_Header (Sock.all, Messages.Host (Host_Address)); end; -- Proxy Authentication Send_Authentication_Header (Connection, Messages.Proxy_Authorization_Token, Connection.Auth (Proxy), URI => "/", Method => "CONNECT"); declare User_Agent : constant String := To_String (Connection.User_Agent); begin if User_Agent /= "" then Send_Header (Sock.all, Messages.User_Agent (User_Agent)); end if; end; -- Empty line to terminate the connect Net.Buffered.New_Line (Sock.all); -- 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 Connection.Opened := False; 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_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); 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; ----------- -- 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 (Natural (Data_Range.First))); end if; Append (Result, "-"); if Data_Range.Last /= Undefined then Append (Result, Utils.Image (Natural (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 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 -- Internal_Post_With_Attachment Build_Root_Part_Header; Retry : loop begin Open_Send_Common_Header (Connection, "POST", URI, Headers); declare Sock : Net.Socket_Type'Class renames Connection.Socket.all; begin -- Send message Content-Type (multipart/related) if Content_Type = "" then Send_Header (Sock, Messages.Content_Type (MIME.Multipart_Related & "; type=" & Content_Type & "; start=""" & Root_Content_Id & '"', Boundary)); else Send_Header (Sock, Messages.Content_Type (MIME.Multipart_Form_Data, Boundary)); end if; if SOAPAction /= Client.No_Data then -- SOAP header if SOAPAction = """""" then -- An empty SOAPAction Send_Header (Sock, Messages.SOAPAction ("")); else Send_Header (Sock, Messages.SOAPAction (SOAPAction)); end if; end if; -- Send message Content-Length Send_Header (Sock, Messages.Content_Length (Content_Length)); Net.Buffered.New_Line (Sock); -- 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); Net.Buffered.New_Line (Sock); -- 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); 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; -------------------------------------- -- 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 use 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 -- Post Data with headers Send_Common_Post (Connection, Data, URI, SOAPAction, Content_Type, Headers); -- 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; ----------------------------- -- Open_Send_Common_Header -- ----------------------------- procedure Open_Send_Common_Header (Connection : in out HTTP_Connection; Method : String; URI : String; Headers : Header_List := Empty_Header_List) is Sock : Net.Socket_Access := Connection.Socket; No_Data : Unbounded_String renames Null_Unbounded_String; Header : constant Header_List := Headers.Union (Connection.Headers, Unique => True); function Persistence return String with Inline; -- Returns "Keep-Alive" is we have a persistent connection and "Close" -- otherwise. function Encoded_URI return String; -- Returns URI encoded (' ' -> '+') ----------------- -- Encoded_URI -- ----------------- function Encoded_URI return String is E_URI : String := URI; begin for K in E_URI'Range loop if E_URI (K) = ' ' then E_URI (K) := '+'; end if; end loop; return E_URI; end Encoded_URI; ----------------- -- 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_Send_Common_Header -- Open connection if needed if not Connection.Opened then Connect (Connection); Sock := Connection.Socket; end if; Sock.Set_Timeout (Connection.Timeouts.Send); -- Header command 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 Send_Header (Sock.all, Method & ' ' & AWS.URL.Pathname_And_Parameters (Connection.Host_URL, False) & ' ' & HTTP_Version); else Send_Header (Sock.all, Method & ' ' & Encoded_URI & ' ' & HTTP_Version); end if; -- Unless Header already contains connection info (like would be -- the case for web sockets for instance) if not Header.Exist (Messages.Connection_Token) then Send_Header (Sock.all, Messages.Connection (Persistence)); end if; else -- We have a proxy configured, in thoses case we want to send the -- absolute path and parameters. if URI = "" then Send_Header (Sock.all, Method & ' ' & AWS.URL.URL (Connection.Host_URL) & ' ' & HTTP_Version); else -- Send GET http://[:port]/URI HTTP/1.1 Send_Header (Sock.all, Method & ' ' & URL.Protocol_Name (Connection.Host_URL) & "://" & Host_Address & Encoded_URI & ' ' & HTTP_Version); end if; Send_Header (Sock.all, Messages.Proxy_Connection (Persistence)); -- Proxy Authentication Send_Authentication_Header (Connection, Messages.Proxy_Authorization_Token, Connection.Auth (Proxy), URI, Method); end if; -- Send specific headers AWS.Headers.Send_Header (Sock.all, Header); if Debug_On then for J in 1 .. Header.Count loop Debug_Message ("> ", Header.Get_Line (J)); end loop; end if; -- Cookie if Connection.Cookie /= No_Data then Send_Header (Sock.all, Messages.Cookie_Token, Messages.Cookie'Access, To_String (Connection.Cookie), Header); end if; Send_Header (Sock.all, Messages.Host_Token, Messages.Host'Access, Host_Address, Header); Send_Header (Sock.all, Messages.Accept_Token, Messages.Accept_Type'Access, "text/html, */*", Header); Send_Header (Sock.all, Messages.Accept_Encoding_Token, Messages.Accept_Encoding'Access, "gzip, deflate", Header); Send_Header (Sock.all, Messages.Accept_Language_Token, Messages.Accept_Language'Access, "fr, ru, us", Header); declare User_Agent : constant String := To_String (Connection.User_Agent); begin if User_Agent /= "" then Send_Header (Sock.all, Messages.User_Agent_Token, Messages.User_Agent'Access, User_Agent, Header); end if; end; if Connection.Data_Range /= No_Range then Send_Header (Sock.all, Messages.Range_Token, Messages.Data_Range'Access, Image (Connection.Data_Range), Header); end if; -- User Authentication Send_Authentication_Header (Connection, Messages.Authorization_Token, Connection.Auth (WWW), URI, Method); end Open_Send_Common_Header; ------------------ -- Parse_Header -- ------------------ procedure Parse_Header (Connection : in out HTTP_Connection; Answer : out Response.Data; Keep_Alive : out Boolean) is Sock : Net.Socket_Type'Class renames Connection.Socket.all; Status : Messages.Status_Code; Request_Auth_Mode : array (Authentication_Level) of Authentication_Mode := (others => Any); 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; -- 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; ----------------------------- -- 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; begin -- Parse_Header for Level in Authentication_Level'Range loop Connection.Auth (Level).Requested := False; end loop; Read_Status_Line; -- 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); Response.Set.Read_Header (Sock, Answer); declare use AWS.Response; Content_Encoding : constant String := Characters.Handling.To_Lower (Header (Answer, Messages.Content_Encoding_Token)); procedure Decode_Init (Header : ZLib.Header_Type); ----------------- -- Decode_Init -- ----------------- procedure Decode_Init (Header : ZLib.Header_Type) is use type Utils.Stream_Element_Array_Access; begin ZLib.Inflate_Init (Connection.Decode_Filter, Header => 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; 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; -- ??? 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 Status = Messages.S100 then Read_Status_Line; Response.Set.Read_Header (Sock, 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)); end Parse_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; -------------------------------- -- Send_Authentication_Header -- -------------------------------- procedure Send_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 Send_Header (Connection.Socket.all, 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_Send_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 Send_Header (Connection.Socket.all, Token & ": Digest " & QOP_Data & "nonce=""" & Nonce & """, username=""" & User & """, realm=""" & Realm & """, uri=""" & URI & """, response=""" & Response & """"); end; end if; end if; end Send_Authentication_Header; ---------------------- -- Send_Common_Post -- ---------------------- procedure Send_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 begin Open_Send_Common_Header (Connection, "POST", URI, Headers); declare Sock : Net.Socket_Type'Class renames Connection.Socket.all; begin if Content_Type /= Client.No_Data then Send_Header (Sock, Messages.Content_Type_Token, Messages.Content_Type'Access, Content_Type, Headers); end if; if SOAPAction /= Client.No_Data then -- SOAP header if SOAPAction = """""" then -- An empty SOAPAction Send_Header (Sock, Messages.SOAPAction ("")); else Send_Header (Sock, Messages.SOAPAction (SOAPAction)); end if; end if; -- Send message Content_Length Send_Header (Sock, Messages.Content_Length (Data'Length)); Net.Buffered.New_Line (Sock); -- Send message body Net.Buffered.Write (Sock, Data); end; end Send_Common_Post; ----------------- -- Send_Header -- ----------------- procedure Send_Header (Sock : Net.Socket_Type'Class; Data : String) is begin Net.Buffered.Put_Line (Sock, Data); Debug_Message ("> ", Data); end Send_Header; procedure Send_Header (Sock : Net.Socket_Type'Class; Header : String; Constructor : not null access function (Value : String) return String; Value : String; Headers : Header_List) is begin if not Headers.Exist (Header) then Send_Header (Sock, Constructor (Value)); end if; end Send_Header; ------------------ -- 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 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_Send_Common_Header (Connection, Method_Kind'Image (Kind), URI, Headers); -- If there is some data to send if Data'Length > 0 then Send_Header (Connection.Socket.all, Messages.Content_Length (Data'Length)); Net.Buffered.New_Line (Connection.Socket.all); -- Send message body Net.Buffered.Write (Connection.Socket.all, Data); else Net.Buffered.New_Line (Connection.Socket.all); 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; ------------------------ -- 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_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;