File : src/aws-client.adb
------------------------------------------------------------------------------
-- Ada Web Server --
-- --
-- Copyright (C) 2000-2003 --
-- ACT-Europe --
-- --
-- Authors: Dmitriy Anisimkov - Pascal Obry --
-- --
-- This library is free software; you can redistribute it and/or modify --
-- it under the terms of the GNU General Public License as published by --
-- the Free Software Foundation; either version 2 of the License, 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. See the GNU --
-- General Public License for more details. --
-- --
-- You should have received a copy of the GNU General Public License --
-- along with this library; if not, write to the Free Software Foundation, --
-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- 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. --
------------------------------------------------------------------------------
-- $Id: aws-client.adb,v 1.119 2003/10/09 15:14:13 obry Exp $
with Ada.Calendar;
with Ada.Characters.Handling;
with Ada.Exceptions;
with Ada.Text_IO;
with Ada.Strings.Unbounded;
with Ada.Strings.Fixed;
with Ada.Streams.Stream_IO;
with Ada.Unchecked_Deallocation;
with GNAT.Calendar.Time_IO;
with AWS.Digest;
with AWS.Headers.Set;
with AWS.Headers.Values;
with AWS.Messages;
with AWS.MIME;
with AWS.Net.Buffered;
with AWS.OS_Lib;
with AWS.Response.Set;
with AWS.Translator;
with AWS.Utils;
package body AWS.Client is
use Ada;
use Ada.Strings.Unbounded;
type Auth_Attempts_Count is
array (Authentication_Level) of Natural range 0 .. 2;
Debug_On : Boolean := False;
procedure Debug_Message (Prefix, Message : in String);
pragma Inline (Debug_Message);
-- Output Message prefixed with Prefix if Debug_On is True and does
-- nothing otherwise.
procedure Get_Response
(Connection : in out HTTP_Connection;
Result : out Response.Data;
Get_Body : in Boolean := True);
-- Receives response from server for GET and POST and HEAD commands.
-- If Get_Body is set then the message body will be read.
procedure Decrement_Authentication_Attempt
(Connection : in out HTTP_Connection;
Counter : in out Auth_Attempts_Count;
Over : out Boolean);
-- Counts the authentication attempts. Over is set to True when
-- authentication attempts are over.
procedure Set_Authentication
(Auth : out Authentication_Type;
User : in String;
Pwd : in String;
Mode : in Authentication_Mode);
-- Internal procedure to set authentication parameters.
procedure Parse_Header
(Connection : in out HTTP_Connection;
Answer : out Response.Data;
Keep_Alive : out Boolean);
-- Read server answer and set corresponding variable with the value
-- read. Most of the fields are ignored right now.
procedure Connect (Connection : in out HTTP_Connection);
-- Open the connection. Raises Connection_Error if it is not possible to
-- establish the connection. In this case all resources are released and
-- Connection.Opened is set to False.
procedure Disconnect (Connection : in out HTTP_Connection);
-- Close connection. Further use is not possible.
procedure Open_Send_Common_Header
(Connection : in out HTTP_Connection;
Method : in String;
URI : in String);
-- Open the the Connection if it is not open. Send the common HTTP headers
-- for all requests like the proxy, authentification, user agent, host.
procedure Internal_Post
(Connection : in out HTTP_Connection;
Result : out Response.Data;
Data : in Streams.Stream_Element_Array;
URI : in String;
SOAPAction : in String);
-- Common base routine for Post and SOAP_Post routines.
procedure Set_Phase
(Connection : in out HTTP_Connection;
Phase : in Client_Phase);
pragma Inline (Set_Phase);
-- Set the phase for the connection. This will activate the Send and
-- Receive timeouts of the cleaner task if needed.
procedure Send_Header
(Sock : in Net.Socket_Type'Class;
Data : in String);
pragma Inline (Send_Header);
-- Send header Data to socket and call Debug_Message.
function Value (V : in String) return Unbounded_String;
-- Returns V as an Unbounded_String if V is not the empty string
-- otherwise it returns Null_Unbounded_String.
------------------
-- Cleaner_Task --
------------------
task body Cleaner_Task is
Connection : HTTP_Connection_Access;
Forever : constant Duration := Duration'Last;
P : Client_Phase := Not_Monitored;
W : Duration;
Timeout : Boolean;
begin
accept Start (Connection : in HTTP_Connection_Access) do
Cleaner_Task.Connection := Connection;
end Start;
Phase_Loop : loop
-- Wait for the job to be done
case P is
when Stopped =>
exit Phase_Loop;
when Not_Monitored =>
W := Forever;
when Receive =>
W := Duration (Connection.Timeouts.Receive);
when Send =>
W := Duration (Connection.Timeouts.Send);
end case;
if W = 0.0 then
P := Not_Monitored;
W := Forever;
end if;
select
accept Next_Phase do
P := Connection.Current_Phase;
Timeout := False;
end Next_Phase;
or
delay W;
Timeout := True;
end select;
-- Still in the same phase after the delay, just close the socket
-- now.
if Timeout
and then P /= Not_Monitored
and then Connection.Opened
then
Disconnect (Connection.all);
end if;
end loop Phase_Loop;
exception
when E : others =>
Text_IO.Put_Line (Exceptions.Exception_Information (E));
end Cleaner_Task;
-----------
-- Close --
-----------
procedure Close (Connection : in out HTTP_Connection) is
procedure Free is new Ada.Unchecked_Deallocation
(Cleaner_Task, Cleaner_Access);
begin
Connection.Current_Phase := Stopped;
if Connection.Cleaner /= null then
begin
-- We don't want to fail here, we really want to free the cleaner
-- object.
if not Connection.Cleaner'Terminated then
Connection.Cleaner.Next_Phase;
end if;
exception
when others =>
null;
end;
while not Connection.Cleaner'Terminated loop
delay 0.01;
end loop;
Free (Connection.Cleaner);
end if;
Disconnect (Connection);
Net.Free (Connection.Socket);
end Close;
-------------
-- Connect --
-------------
procedure Connect (Connection : in out HTTP_Connection) is
use type Net.Socket_Access;
Connect_URL : AWS.URL.Object renames Connection.Connect_URL;
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;
Connection.Socket := Net.Socket (AWS.URL.Security (Connect_URL));
Net.Connect (Connection.Socket.all,
AWS.URL.Host (Connect_URL),
AWS.URL.Port (Connect_URL));
Connection.Opened := True;
exception
when E : Net.Socket_Error =>
Connection.Opened := False;
Exceptions.Raise_Exception
(Connection_Error'Identity,
"can't connect to " & AWS.URL.URL (Connect_URL)
& " -> " & Exceptions.Exception_Information (E));
end Connect;
-----------------
-- Copy_Cookie --
-----------------
procedure Copy_Cookie
(Source : in HTTP_Connection;
Destination : in out HTTP_Connection) is
begin
Destination.Cookie := Source.Cookie;
end Copy_Cookie;
------------
-- Create --
------------
procedure Create
(Connection : in out HTTP_Connection;
Host : in String;
User : in String := No_Data;
Pwd : in String := No_Data;
Proxy : in String := No_Data;
Proxy_User : in String := No_Data;
Proxy_Pwd : in String := No_Data;
Retry : in Natural := Retry_Default;
Persistent : in Boolean := True;
Timeouts : in Timeouts_Values := No_Timeout;
Server_Push : in Boolean := False)
is
Connect_URL : AWS.URL.Object;
Host_URL : AWS.URL.Object := AWS.URL.Parse (Host);
Proxy_URL : AWS.URL.Object := AWS.URL.Parse (Proxy);
begin
-- If there is a proxy, the host to connect to is the proxy otherwise
-- we connect to the Web server.
if Proxy = No_Data then
Connect_URL := Host_URL;
else
Connect_URL := Proxy_URL;
end if;
Connection.Host := To_Unbounded_String (Host);
Connection.Host_URL := Host_URL;
Connection.Connect_URL := Connect_URL;
Connection.Auth (WWW).User := Value (User);
Connection.Auth (WWW).Pwd := Value (Pwd);
Connection.Proxy := Value (Proxy);
Connection.Proxy_URL := Proxy_URL;
Connection.Auth (Client.Proxy).User := Value (Proxy_User);
Connection.Auth (Client.Proxy).Pwd := Value (Proxy_Pwd);
Connection.Retry := Create.Retry;
Connection.Cookie := Null_Unbounded_String;
Connection.Persistent := Persistent;
Connection.Current_Phase := Not_Monitored;
Connection.Server_Push := Server_Push;
Connection.Timeouts := Timeouts;
-- If we have set the proxy or standard authentication we must set the
-- authentication mode to Basic.
if Proxy_User /= No_Data then
Connection.Auth (Client.Proxy).Work_Mode := Basic;
end if;
if User /= No_Data then
Connection.Auth (WWW).Work_Mode := Basic;
end if;
-- Establish the connection now
Connect (Connection);
if Persistent and then Connection.Retry = 0 then
-- In this case the connection termination can be initiated by the
-- server or the client after a period. So the connection could be
-- closed while trying to get some data from the server. To be nicer
-- from user's point of view just make sure we retry at least one
-- time before reporting an error.
Connection.Retry := 1;
end if;
if Connection.Timeouts /= No_Timeout then
-- If we have some timeouts, initialize the cleaner task.
Connection.Cleaner := new Cleaner_Task;
Connection.Cleaner.Start (Connection.Self);
end if;
end Create;
-------------------
-- Debug_Message --
-------------------
procedure Debug_Message (Prefix, Message : in String) is
begin
if Debug_On then
Text_IO.Put_Line (Prefix & Message);
end if;
end Debug_Message;
--------------------------------------
-- 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
Net.Shutdown (Connection.Socket.all);
end if;
end if;
end Disconnect;
---------
-- Get --
---------
function Get
(URL : in String;
User : in String := No_Data;
Pwd : in String := No_Data;
Proxy : in String := No_Data;
Proxy_User : in String := No_Data;
Proxy_Pwd : in String := No_Data;
Timeouts : in Timeouts_Values := No_Timeout;
Follow_Redirection : in Boolean := False)
return Response.Data
is
use type Messages.Status_Code;
Result : Response.Data;
begin
declare
Connection : HTTP_Connection;
begin
Create (Connection,
URL, User, Pwd, Proxy, Proxy_User, Proxy_Pwd,
Persistent => False,
Timeouts => Timeouts);
Get (Connection, Result);
Close (Connection);
exception
when others =>
Close (Connection);
raise;
end;
if Follow_Redirection
and then Response.Status_Code (Result) = Messages.S305
then
-- This is "Use Proxy" message, Location point to the proxy to use.
-- We do not have the login/password for the proxy.
return Get
(URL, User, Pwd, Response.Location (Result),
Timeouts => Timeouts, Follow_Redirection => Follow_Redirection);
elsif Follow_Redirection
and then
Response.Status_Code (Result) in Messages.S301 .. Messages.S307
and then
Response.Status_Code (Result) /= Messages.S304
then
-- All other redirections, 304 is not one of them.
return Get
(Response.Location (Result), User, Pwd,
Proxy, Proxy_User, Proxy_Pwd, Timeouts, Follow_Redirection);
else
return Result;
end if;
end Get;
---------
-- Get --
---------
procedure Get
(Connection : in out HTTP_Connection;
Result : out Response.Data;
URI : in String := No_Data)
is
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, "GET", URI);
Net.Buffered.New_Line (Connection.Socket.all);
Get_Response (Connection, Result, not Connection.Server_Push);
Decrement_Authentication_Attempt
(Connection, Auth_Attempts, Auth_Is_Over);
if Auth_Is_Over then
return;
end if;
exception
when Net.Socket_Error =>
Disconnect (Connection);
if Try_Count = 0 then
Result := Response.Build
(MIME.Text_HTML, "Get Timeout", Messages.S408);
Set_Phase (Connection, Not_Monitored);
exit Retry;
end if;
Try_Count := Try_Count - 1;
end;
end loop Retry;
end Get;
------------------
-- Get_Response --
------------------
procedure Get_Response
(Connection : in out HTTP_Connection;
Result : out Response.Data;
Get_Body : in Boolean := True)
is
procedure Read_Chunked;
-- Read a chunked object from the stream
procedure Read_Binary_Message (Len : in Positive);
pragma Inline (Read_Binary_Message);
-- Read a binary message of Len bytes from the socket.
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 not Connection.Server_Push then
Disconnect (Connection);
end if;
end Disconnect;
-------------------------
-- Read_Binary_Message --
-------------------------
procedure Read_Binary_Message (Len : in Positive) is
use Streams;
Elements : Stream_Element_Array (1 .. 10_240);
Remain : Stream_Element_Offset := Stream_Element_Offset (Len);
begin
-- Read the message, 10k at a time
loop
if Elements'Length < Remain then
Net.Buffered.Read (Sock, Elements);
Response.Set.Append_Body (Result, Elements);
else
Net.Buffered.Read (Sock, Elements (1 .. Remain));
Response.Set.Append_Body (Result, Elements (1 .. Remain));
exit;
end if;
Remain := Remain - Elements'Length;
end loop;
end Read_Binary_Message;
------------------
-- Read_Chunked --
------------------
procedure Read_Chunked is
use Streams;
use type Stream_Element_Array;
use type Stream_Element_Offset;
procedure Skip_Line;
-- skip a line on the socket
---------------
-- Skip_Line --
---------------
procedure Skip_Line is
D : constant String := Net.Buffered.Get_Line (Sock);
pragma Warnings (Off, D);
begin
null;
end Skip_Line;
Size : Stream_Element_Offset;
begin
loop
-- Read the chunk size that is an hex number
declare
L : constant String := Net.Buffered.Get_Line (Sock);
begin
Size := Stream_Element_Offset
(Utils.Hex_Value (Strings.Fixed.Trim (L, Strings.Both)));
end;
if Size = 0 then
Skip_Line;
exit;
else
declare
Chunk : Stream_Element_Array (1 .. Size);
begin
Net.Buffered.Read (Sock, Chunk);
Response.Set.Append_Body (Result, Chunk);
end;
Skip_Line;
end if;
end loop;
end Read_Chunked;
begin
Set_Phase (Connection, Receive);
-- Clear the data in the response
Response.Set.Clear (Result);
Parse_Header (Connection, Result, Keep_Alive);
if not Get_Body then
Disconnect;
Set_Phase (Connection, Not_Monitored);
return;
end if;
-- Read the message body
declare
TE : constant String
:= Response.Header (Result, Messages.Transfer_Encoding_Token);
CT_Len : constant Integer := Response.Content_Length (Result);
begin
if TE = "chunked" then
-- A chuncked message is written on the stream as list of data
-- chunk. Each chunk has the following format:
--
-- <N : the chunk size in hexadecimal> CRLF
-- <N * BYTES : the data> CRLF
--
-- The termination chunk is:
--
-- 0 CRLF
-- CRLF
--
Read_Chunked;
else
if CT_Len = Response.Undefined_Length then
Read_Until_Close : begin
loop
declare
Data : constant Streams.Stream_Element_Array
:= Net.Buffered.Read (Sock);
begin
Response.Set.Append_Body (Result, Data);
end;
end loop;
exception
when Net.Socket_Error =>
null;
end Read_Until_Close;
else
if CT_Len > 0 then
Read_Binary_Message (CT_Len);
end if;
end if;
end if;
end;
Disconnect;
Set_Phase (Connection, Not_Monitored);
end Get_Response;
----------
-- Head --
----------
function Head
(URL : in String;
User : in String := No_Data;
Pwd : in String := No_Data;
Proxy : in String := No_Data;
Proxy_User : in String := No_Data;
Proxy_Pwd : in String := No_Data;
Timeouts : in Timeouts_Values := No_Timeout)
return Response.Data
is
Connection : HTTP_Connection;
Result : Response.Data;
begin
Create (Connection,
URL, User, Pwd, Proxy, Proxy_User, Proxy_Pwd,
Persistent => False,
Timeouts => Timeouts);
Head (Connection, Result);
Close (Connection);
return Result;
exception
when others =>
Close (Connection);
raise;
end Head;
----------
-- Head --
----------
procedure Head
(Connection : in out HTTP_Connection;
Result : out Response.Data;
URI : in String := No_Data)
is
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, "HEAD", URI);
Net.Buffered.New_Line (Connection.Socket.all);
Get_Response (Connection, Result, Get_Body => False);
Decrement_Authentication_Attempt
(Connection, Auth_Attempts, Auth_Is_Over);
if Auth_Is_Over then
return;
end if;
exception
when Net.Socket_Error =>
Disconnect (Connection);
if Try_Count = 0 then
Result := Response.Build
(MIME.Text_HTML, "Head Timeout", Messages.S408);
Set_Phase (Connection, Not_Monitored);
exit Retry;
end if;
Try_Count := Try_Count - 1;
end;
end loop Retry;
end Head;
-------------------
-- Internal_Post --
-------------------
procedure Internal_Post
(Connection : in out HTTP_Connection;
Result : out Response.Data;
Data : in Streams.Stream_Element_Array;
URI : in String;
SOAPAction : in String)
is
No_Data : Unbounded_String renames Null_Unbounded_String;
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, "POST", URI);
declare
Sock : Net.Socket_Type'Class renames Connection.Socket.all;
begin
if SOAPAction = No_Data then
Send_Header
(Sock,
Messages.Content_Type (MIME.Application_Form_Data));
else
-- SOAP header
Send_Header (Sock, Messages.SOAPAction (SOAPAction));
Send_Header
(Sock,
Messages.Content_Type (MIME.Text_XML));
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;
-- Get answer from server
Get_Response (Connection, Result, not Connection.Server_Push);
Decrement_Authentication_Attempt
(Connection, Auth_Attempts, Auth_Is_Over);
if Auth_Is_Over then
return;
end if;
exception
when Net.Socket_Error =>
Disconnect (Connection);
if Try_Count = 0 then
Result := Response.Build
(MIME.Text_HTML, "Post Timeout", Messages.S408);
Set_Phase (Connection, Not_Monitored);
exit Retry;
end if;
Try_Count := Try_Count - 1;
end;
end loop Retry;
end Internal_Post;
-----------------------------
-- Open_Send_Common_Header --
-----------------------------
procedure Open_Send_Common_Header
(Connection : in out HTTP_Connection;
Method : in String;
URI : in String)
is
Sock : Net.Socket_Access renames Connection.Socket;
No_Data : Unbounded_String renames Null_Unbounded_String;
procedure Send_Authentication_Header
(Token : in String;
Data : in out Authentication_Type);
-- Send the authentication header for proxy or for server
function HTTP_Prefix (Security : in Boolean) return String;
-- Returns "http://" or "https://" if Security is set to True
function Persistence return String;
-- Returns "Keep-Alive" is we have a persistent connection and "Close"
-- otherwise.
function Port_Not_Default (Port : in Positive) return String;
-- Returns the port image (preceded by character ':') if it is not the
-- default port.
-----------------
-- HTTP_Prefix --
-----------------
function HTTP_Prefix (Security : in Boolean) return String is
begin
if Security then
return "https://";
else
return "http://";
end if;
end HTTP_Prefix;
-----------------
-- Persistence --
-----------------
function Persistence return String is
begin
if Connection.Persistent then
return "Keep-Alive";
else
return "Close";
end if;
end Persistence;
----------------------
-- Port_Not_Default --
----------------------
function Port_Not_Default (Port : in Positive) return String is
begin
if Port = 80 then
return "";
else
declare
Port_Image : constant String := Positive'Image (Port);
begin
return ':' & Port_Image (2 .. Port_Image'Last);
end;
end if;
end Port_Not_Default;
--------------------------------
-- Send_Authentication_Header --
--------------------------------
procedure Send_Authentication_Header
(Token : in String;
Data : in out Authentication_Type)
is
User : constant String := To_String (Data.User);
Pwd : constant String := To_String (Data.Pwd);
begin
if User /= No_Data and then Pwd /= No_Data then
if Data.Work_Mode = Basic then
Send_Header
(Sock.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 String := AWS.Digest.Create_Nonce;
begin
if QOP = No_Data then
Response := AWS.Digest.Create_Digest
(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_Digest
(Username => User,
Realm => Realm,
Password => Pwd,
Nonce => Nonce,
CNonce => CNonce,
NC => NC,
QOP => QOP,
Method => Method,
URI => URI);
return "qop=""" & QOP
& """, cnonce=""" & CNonce
& """, nc=" & NC
& ", ";
end;
end if;
end QOP_Data;
begin
Send_Header
(Sock.all,
Token & ": Digest "
& QOP_Data
& "nonce=""" & Nonce
& """, username=""" & User
& """, realm=""" & Realm
& """, uri=""" & URI
& """, response=""" & Response
& """");
end;
end if;
end if;
end Send_Authentication_Header;
Host_Address : constant String
:= AWS.URL.Host (Connection.Host_URL)
& Port_Not_Default (AWS.URL.Port (Connection.Host_URL));
begin
-- Open connection if needed
if not Connection.Opened then
Connect (Connection);
end if;
Set_Phase (Connection, Send);
-- Header command
if Connection.Proxy = No_Data then
if URI = "" then
Send_Header
(Sock.all,
Method & ' '
& AWS.URL.Pathname_And_Parameters (Connection.Host_URL, False)
& ' ' & HTTP_Version);
else
-- URI should already be encoded, but to help a bit Windows
-- systems who tend to have spaces into URL we encode them here.
declare
E_URI : String := URI;
begin
for K in E_URI'Range loop
if E_URI (K) = ' ' then
E_URI (K) := '+';
end if;
end loop;
Send_Header
(Sock.all,
Method & ' ' & E_URI & ' ' & HTTP_Version);
end;
end if;
Send_Header
(Sock.all, Messages.Connection (Persistence));
else
if URI = "" then
Send_Header (Sock.all,
Method & ' '
& To_String (Connection.Host)
& ' ' & HTTP_Version);
else
Send_Header
(Sock.all,
Method & ' '
& HTTP_Prefix (AWS.URL.Security (Connection.Host_URL))
& Host_Address & URI
& ' ' & HTTP_Version);
end if;
Send_Header
(Sock.all, Messages.Proxy_Connection (Persistence));
end if;
-- Cookie
if Connection.Cookie /= No_Data then
Send_Header
(Sock.all, Messages.Cookie (To_String (Connection.Cookie)));
end if;
Send_Header (Sock.all,
Messages.Host (Host_Address));
Send_Header (Sock.all,
Messages.Accept_Type ("text/html, */*"));
Send_Header (Sock.all,
Messages.Accept_Encoding_Token & ": deflate, gzip");
Send_Header (Sock.all,
Messages.Accept_Language ("fr, ru, us"));
Send_Header (Sock.all,
Messages.User_Agent ("AWS (Ada Web Server) v" & Version));
-- User Authentification
Send_Authentication_Header
(Messages.Authorization_Token, Connection.Auth (WWW));
-- Proxy Authentification
Send_Authentication_Header
(Messages.Proxy_Authorization_Token, Connection.Auth (Proxy));
Set_Phase (Connection, Not_Monitored);
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 : in Authentication_Level;
Auth_Line : in 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 : in String);
-- Set the Parse_Header.Keep_Alive depending on data from the
-- Proxy-Connection or Connection header line.
function "+" (S : in String) return Unbounded_String
renames To_Unbounded_String;
-----------------------------
-- Parse_Authenticate_Line --
-----------------------------
procedure Parse_Authenticate_Line
(Level : in Authentication_Level;
Auth_Line : in 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 : in String;
Quit : in out Boolean);
-- Routine receiving unnamed value during parsing of
-- authentication line.
procedure Named_Value
(Name : in String;
Value : in String;
Quit : in out Boolean);
-- Routine receiving name/value pairs during parsing of
-- authentication line.
-----------------
-- Named_Value --
-----------------
procedure Named_Value
(Name : in String;
Value : in 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
Ada.Exceptions.Raise_Exception
(Constraint_Error'Identity,
"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 : in 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;
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 Messages.Match (Line, Messages.HTTP_Token) then
Status := Messages.Status_Code'Value
('S' & Line (Messages.HTTP_Token'Last + 5
.. Messages.HTTP_Token'Last + 7));
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'Last + 1
.. Messages.HTTP_Token'Last + 3) >= "1.1";
else
-- or else it is wrong answer from server
Ada.Exceptions.Raise_Exception (Protocol_Error'Identity, Line);
end if;
end Read_Status_Line;
--------------------
-- Set_Keep_Alive --
--------------------
procedure Set_Keep_Alive (Data : in String) is
begin
if Messages.Match (Data, "Close") then
Keep_Alive := False;
elsif Messages.Match (Data, "Keep-Alive") then
Keep_Alive := True;
end if;
end Set_Keep_Alive;
use type Messages.Status_Code;
begin
for Level in Authentication_Level'Range loop
Connection.Auth (Level).Requested := False;
end loop;
Read_Status_Line;
Response.Set.Read_Header (Sock, Answer);
declare
use AWS.Response;
Content_Encoding : constant String
:= Ada.Characters.Handling.To_Lower
(Header (Answer, Messages.Content_Encoding_Token));
begin
if Content_Encoding = "gzip" then
Set.Data_Encoding (Answer, Messages.GZip, Set.Decode);
elsif Content_Encoding = "deflate" then
Set.Data_Encoding (Answer, Messages.Deflate, Set.Decode);
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));
-- ??? We handle a single cookie on the client side. This must be
-- fixed. Every cookie received should be stored and sent back to the
-- server.
declare
Set_Cookie : constant String
:= Response.Header (Answer, Messages.Set_Cookie_Token);
begin
-- Set the new cookie, only if the server sent Set-Cookie
-- header line.
if Set_Cookie /= "" then
Connection.Cookie := +Set_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;
----------
-- Post --
----------
function Post
(URL : in String;
Data : in String;
User : in String := No_Data;
Pwd : in String := No_Data;
Proxy : in String := No_Data;
Proxy_User : in String := No_Data;
Proxy_Pwd : in String := No_Data;
Timeouts : in Timeouts_Values := No_Timeout)
return Response.Data
is
use Streams;
begin
return Post (URL, Translator.To_Stream_Element_Array (Data),
User, Pwd, Proxy, Proxy_User, Proxy_Pwd, Timeouts);
end Post;
----------
-- Post --
----------
function Post
(URL : in String;
Data : in Streams.Stream_Element_Array;
User : in String := No_Data;
Pwd : in String := No_Data;
Proxy : in String := No_Data;
Proxy_User : in String := No_Data;
Proxy_Pwd : in String := No_Data;
Timeouts : in Timeouts_Values := No_Timeout)
return Response.Data
is
Connection : HTTP_Connection;
Result : Response.Data;
begin
Create (Connection,
URL, User, Pwd, Proxy, Proxy_User, Proxy_Pwd,
Persistent => False,
Timeouts => Timeouts);
Post (Connection, Result, Data);
Close (Connection);
return Result;
exception
when others =>
Close (Connection);
raise;
end Post;
----------
-- Post --
----------
procedure Post
(Connection : in out HTTP_Connection;
Result : out Response.Data;
Data : in Streams.Stream_Element_Array;
URI : in String := No_Data) is
begin
Internal_Post (Connection, Result, Data, URI, SOAPAction => No_Data);
end Post;
----------
-- Post --
----------
procedure Post
(Connection : in out HTTP_Connection;
Result : out Response.Data;
Data : in String;
URI : in String := No_Data) is
begin
Post (Connection, Result,
Translator.To_Stream_Element_Array (Data), URI);
end Post;
---------
-- Put --
---------
function Put
(URL : in String;
Data : in String;
User : in String := No_Data;
Pwd : in String := No_Data;
Proxy : in String := No_Data;
Proxy_User : in String := No_Data;
Proxy_Pwd : in String := No_Data;
Timeouts : in Timeouts_Values := No_Timeout)
return Response.Data
is
Connection : HTTP_Connection;
Result : Response.Data;
begin
Create (Connection,
URL, User, Pwd, Proxy, Proxy_User, Proxy_Pwd,
Persistent => False,
Timeouts => Timeouts);
Put (Connection, Result, Data);
Close (Connection);
return Result;
exception
when others =>
Close (Connection);
raise;
end Put;
---------
-- Put --
---------
procedure Put
(Connection : in out HTTP_Connection;
Result : out Response.Data;
Data : in String;
URI : in String := No_Data)
is
Keep_Alive : Boolean;
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, "PUT", URI);
-- Send message Content_Length
Send_Header
(Connection.Socket.all, Messages.Content_Length (Data'Length));
Net.Buffered.New_Line (Connection.Socket.all);
-- Send message body
Net.Buffered.Put_Line (Connection.Socket.all, Data);
-- Get answer from server
Parse_Header
(Connection, Result, Keep_Alive);
if not Keep_Alive then
Disconnect (Connection);
end if;
Decrement_Authentication_Attempt
(Connection, Auth_Attempts, Auth_Is_Over);
if Auth_Is_Over then
return;
end if;
exception
when Net.Socket_Error =>
Disconnect (Connection);
if Try_Count = 0 then
Result := Response.Build
(MIME.Text_HTML, "Put Timeout", Messages.S408);
Set_Phase (Connection, Not_Monitored);
exit Retry;
end if;
Try_Count := Try_Count - 1;
end;
end loop Retry;
end Put;
----------------
-- Read_Until --
----------------
function Read_Until
(Connection : in HTTP_Connection;
Delimiter : in String)
return String
is
Result : Unbounded_String;
begin
Read_Until (Connection.Self.all, Delimiter, Result);
return To_String (Result);
end Read_Until;
procedure Read_Until
(Connection : in out HTTP_Connection;
Delimiter : in String;
Result : in out Ada.Strings.Unbounded.Unbounded_String)
is
Sample_Idx : Natural := Delimiter'First;
Buffer : String (1 .. 1024);
begin
Set_Phase (Connection, Receive);
Main : loop
for I in Buffer'Range loop
begin
Buffer (I) := Net.Buffered.Get_Char (Connection.Socket.all);
exception
when Net.Socket_Error =>
Append (Result, Buffer (Buffer'First .. I - 1));
exit Main;
end;
if Buffer (I) = Delimiter (Sample_Idx) then
if Sample_Idx = Delimiter'Last then
Append (Result, Buffer (Buffer'First .. I));
exit Main;
else
Sample_Idx := Sample_Idx + 1;
end if;
else
Sample_Idx := Delimiter'First;
end if;
end loop;
Append (Result, Buffer);
end loop Main;
Set_Phase (Connection, Not_Monitored);
end Read_Until;
-----------------
-- Send_Header --
-----------------
procedure Send_Header
(Sock : in Net.Socket_Type'Class;
Data : in String) is
begin
Net.Buffered.Put_Line (Sock, Data);
Debug_Message ("> ", Data);
end Send_Header;
------------------------
-- Set_Authentication --
------------------------
procedure Set_Authentication
(Auth : out Authentication_Type;
User : in String;
Pwd : in String;
Mode : in 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_Debug --
---------------
procedure Set_Debug (On : in Boolean) is
begin
Debug_On := On;
AWS.Headers.Set.Debug (On);
end Set_Debug;
---------------
-- Set_Phase --
---------------
procedure Set_Phase
(Connection : in out HTTP_Connection;
Phase : in Client_Phase) is
begin
Connection.Current_Phase := Phase;
if Connection.Cleaner /= null then
Connection.Cleaner.Next_Phase;
end if;
end Set_Phase;
------------------------------
-- Set_Proxy_Authentication --
------------------------------
procedure Set_Proxy_Authentication
(Connection : in out HTTP_Connection;
User : in String;
Pwd : in String;
Mode : in Authentication_Mode) is
begin
Set_Authentication
(Auth => Connection.Auth (Proxy),
User => User,
Pwd => Pwd,
Mode => Mode);
end Set_Proxy_Authentication;
----------------------------
-- Set_WWW_Authentication --
----------------------------
procedure Set_WWW_Authentication
(Connection : in out HTTP_Connection;
User : in String;
Pwd : in String;
Mode : in Authentication_Mode) is
begin
Set_Authentication
(Auth => Connection.Auth (WWW),
User => User,
Pwd => Pwd,
Mode => Mode);
end Set_WWW_Authentication;
---------------
-- SOAP_Post --
---------------
function SOAP_Post
(URL : in String;
Data : in String;
SOAPAction : in String;
User : in String := No_Data;
Pwd : in String := No_Data;
Proxy : in String := No_Data;
Proxy_User : in String := No_Data;
Proxy_Pwd : in String := No_Data;
Timeouts : in Timeouts_Values := No_Timeout)
return Response.Data
is
Connection : HTTP_Connection;
Result : Response.Data;
begin
Create (Connection,
URL, User, Pwd, Proxy, Proxy_User, Proxy_Pwd,
Persistent => False,
Timeouts => Timeouts);
SOAP_Post (Connection, Result, SOAPAction, Data => Data);
Close (Connection);
return Result;
exception
when others =>
Close (Connection);
raise;
end SOAP_Post;
procedure SOAP_Post
(Connection : in HTTP_Connection;
Result : out Response.Data;
SOAPAction : in String;
Data : in String) is
begin
Internal_Post
(Connection => Connection.Self.all,
Result => Result,
Data => AWS.Translator.To_Stream_Element_Array (Data),
URI => No_Data,
SOAPAction => SOAPAction);
end SOAP_Post;
------------
-- Upload --
------------
procedure Upload
(Connection : in out HTTP_Connection;
Result : out Response.Data;
Filename : in String;
URI : in String := No_Data)
is
Pref_Suf : constant String := "--";
Now : constant Calendar.Time := Calendar.Clock;
Boundary : constant String
:= "AWS_File_Upload-" & GNAT.Calendar.Time_IO.Image (Now, "%s");
CT : constant String
:= Messages.Content_Type (MIME.Content_Type (Filename));
CD : constant String
:= Messages.Content_Disposition ("form-data", "filename", Filename);
Try_Count : Natural := Connection.Retry;
Auth_Attempts : Auth_Attempts_Count := (others => 2);
Auth_Is_Over : Boolean;
function Content_Length return Integer;
-- Returns the total message content length.
procedure Send_File;
-- Send file content to the server.
--------------------
-- Content_Length --
--------------------
function Content_Length return Integer is
begin
return 2 * Boundary'Length -- 2 boundaries
+ 2 -- second one end with "--"
+ 10 -- 5 lines with CR+LF
+ CT'Length -- content length header
+ CD'Length -- content disposition head
+ Integer (OS_Lib.File_Size (Filename)) -- 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 : Streams.Stream_Element_Array (1 .. 4_096);
Last : Streams.Stream_Element_Offset;
File : Streams.Stream_IO.File_Type;
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
Streams.Stream_IO.Open (File, Streams.Stream_IO.In_File, Filename);
while not Streams.Stream_IO.End_Of_File (File) loop
Streams.Stream_IO.Read (File, Buffer, Last);
Net.Buffered.Write (Sock, Buffer (1 .. Last));
end loop;
Streams.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 Streams.Stream_IO.Is_Open (File) then
Streams.Stream_IO.Close (File);
end if;
raise;
end Send_File;
begin
Retry : loop
begin
Open_Send_Common_Header (Connection, "POST", URI);
declare
Sock : Net.Socket_Type'Class renames Connection.Socket.all;
begin
-- Send message Content-Type (Multipart/form-data)
Send_Header
(Sock,
Messages.Content_Type (MIME.Multipart_Form_Data, Boundary));
-- Send message Content-Length
Send_Header (Sock, Messages.Content_Length (Content_Length));
Net.Buffered.New_Line (Sock);
-- Send message body
Send_File;
end;
-- Get answer from server
Get_Response (Connection, Result, not Connection.Server_Push);
Decrement_Authentication_Attempt
(Connection, Auth_Attempts, Auth_Is_Over);
if Auth_Is_Over then
return;
end if;
exception
when Net.Socket_Error =>
Disconnect (Connection);
if Try_Count = 0 then
Result := Response.Build
(MIME.Text_HTML, "Upload Timeout", Messages.S408);
Set_Phase (Connection, Not_Monitored);
exit Retry;
end if;
Try_Count := Try_Count - 1;
end;
end loop Retry;
end Upload;
function Upload
(URL : in String;
Filename : in String;
User : in String := No_Data;
Pwd : in String := No_Data;
Proxy : in String := No_Data;
Proxy_User : in String := No_Data;
Proxy_Pwd : in String := No_Data;
Timeouts : in Timeouts_Values := No_Timeout)
return Response.Data
is
Connection : HTTP_Connection;
Result : Response.Data;
begin
Create (Connection,
URL, User, Pwd, Proxy, Proxy_User, Proxy_Pwd,
Persistent => False,
Timeouts => Timeouts);
Upload (Connection, Result, Filename);
Close (Connection);
return Result;
exception
when others =>
Close (Connection);
raise;
end Upload;
-----------
-- Value --
-----------
function Value (V : in String) return Unbounded_String is
begin
if V = No_Data then
return Null_Unbounded_String;
else
return To_Unbounded_String (V);
end if;
end Value;
end AWS.Client;