File : src/aws-status.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-status.adb,v 1.56 2003/10/10 03:05:48 anisimko Exp $
with Ada.Characters.Handling;
with Ada.Exceptions;
with Ada.Strings;
with AWS.Digest;
with AWS.Headers.Values;
with AWS.Messages;
with AWS.Translator;
package body AWS.Status is
use Ada.Strings;
---------------------
-- Accept_Encoding --
---------------------
function Accept_Encoding (D : in Data) return String is
begin
return Headers.Get (D.Header, Messages.Accept_Encoding_Token);
end Accept_Encoding;
--------------------------
-- Authorization_CNonce --
--------------------------
function Authorization_CNonce (D : in Data) return String is
begin
return To_String (D.Auth_CNonce);
end Authorization_CNonce;
------------------------
-- Authorization_Mode --
------------------------
function Authorization_Mode (D : in Data) return Authorization_Type is
begin
return D.Auth_Mode;
end Authorization_Mode;
------------------------
-- Authorization_Name --
------------------------
function Authorization_Name (D : in Data) return String is
begin
return To_String (D.Auth_Name);
end Authorization_Name;
----------------------
-- Authorization_NC --
----------------------
function Authorization_NC (D : in Data) return String is
begin
return To_String (D.Auth_NC);
end Authorization_NC;
-------------------------
-- Authorization_Nonce --
-------------------------
function Authorization_Nonce (D : in Data) return String is
begin
return To_String (D.Auth_Nonce);
end Authorization_Nonce;
----------------------------
-- Authorization_Password --
----------------------------
function Authorization_Password (D : in Data) return String is
begin
return To_String (D.Auth_Password);
end Authorization_Password;
-----------------------
-- Authorization_QOP --
-----------------------
function Authorization_QOP (D : in Data) return String is
begin
return To_String (D.Auth_QOP);
end Authorization_QOP;
-------------------------
-- Authorization_Realm --
-------------------------
function Authorization_Realm (D : in Data) return String is
begin
return To_String (D.Auth_Realm);
end Authorization_Realm;
----------------------------
-- Authorization_Response --
----------------------------
function Authorization_Response (D : in Data) return String is
begin
return To_String (D.Auth_Response);
end Authorization_Response;
-----------------
-- Binary_Data --
-----------------
function Binary_Data (D : in Data) return Stream_Element_Array is
begin
return D.Binary_Data.all;
end Binary_Data;
------------------
-- Check_Digest --
------------------
function Check_Digest (D : in Data; Password : in String) return Boolean is
use type Messages.Status_Code;
begin
return Check_Digest (D, Password) = Messages.S200;
end Check_Digest;
function Check_Digest
(D : in Data;
Password : in String)
return Messages.Status_Code
is
Nonce : constant String := Authorization_Nonce (D);
Auth_URI : constant String := To_String (D.Auth_URI);
Auth_URL : constant URL.Object
:= URL.Parse (Auth_URI, Check_Validity => False, Normalize => True);
Data_URL : URL.Object := D.URI;
function Get_Nonce return String;
-- Returns Nonce for the Digest authentication without "qop"
-- parameter, or [nonce]:[nc]:[cnonce]:[qop] for the Digest
-- authentication with qop parameter.
-- It is just for convenience to implement RFC 2617 3.2.2.1.
---------------
-- Get_Nonce --
---------------
function Get_Nonce return String is
QOP : constant String := Authorization_QOP (D);
begin
if QOP = "" then
return Nonce;
else
return Nonce
& ':' & Authorization_NC (D)
& ':' & Authorization_CNonce (D)
& ':' & QOP;
end if;
end Get_Nonce;
begin
URL.Normalize (Data_URL);
if URL.Abs_Path (Data_URL) /= URL.Abs_Path (Auth_URL)
or else Nonce = ""
then
-- Bad request.
return Messages.S400;
elsif Authorization_Response (D)
/=
AWS.Digest.Create_Digest
(Username => Authorization_Name (D),
Realm => Authorization_Realm (D),
Password => Password,
Nonce => Get_Nonce,
Method => Request_Method'Image (D.Method),
URI => Auth_URI)
then
-- Unauthorized.
return Messages.S401;
else
-- Successful.
return Messages.S200;
end if;
end Check_Digest;
----------------
-- Connection --
----------------
function Connection (D : in Data) return String is
begin
return Headers.Get (D.Header, Messages.Connection_Token);
end Connection;
--------------------
-- Content_Length --
--------------------
function Content_Length (D : in Data) return Natural is
begin
return D.Content_Length;
end Content_Length;
------------------
-- Content_Type --
------------------
function Content_Type (D : in Data) return String is
begin
return Headers.Get (D.Header, Messages.Content_Type_Token);
end Content_Type;
-----------------
-- Has_Session --
-----------------
function Has_Session (D : in Data) return Boolean is
use type AWS.Session.ID;
begin
return D.Session_ID /= AWS.Session.No_Session;
end Has_Session;
------------
-- Header --
------------
function Header (D : in Data) return Headers.List is
begin
return D.Header;
end Header;
----------
-- Host --
----------
function Host (D : in Data) return String is
begin
return Headers.Get (D.Header, Messages.Host_Token);
end Host;
------------------
-- HTTP_Version --
------------------
function HTTP_Version (D : in Data) return String is
begin
return To_String (D.HTTP_Version);
end HTTP_Version;
-----------------------
-- If_Modified_Since --
-----------------------
function If_Modified_Since (D : in Data) return String is
begin
return Headers.Get (D.Header, Messages.If_Modified_Since_Token);
end If_Modified_Since;
-------------
-- Is_SOAP --
-------------
function Is_SOAP (D : in Data) return Boolean is
begin
return D.SOAP_Action;
end Is_SOAP;
------------------
-- Is_Supported --
------------------
function Is_Supported
(D : in Data;
Encoding : in Messages.Content_Encoding)
return Boolean
is
function To_Lower (Item : String) return String
renames Ada.Characters.Handling.To_Lower;
Encoding_Image : constant String
:= To_Lower (Messages.Content_Encoding'Image (Encoding));
Found_Encoding : Boolean := False;
Enable_Encoding : Boolean := True;
-- QValue is 1 by default, i.e enought.
Just_Found_Others : Boolean := False;
Found_Others : Boolean := False;
-- Found others - "*" symbol.
Enable_Others : Boolean := True;
-- All others encoding enabled by default.
procedure Named_Value (Name, Value : in String; Quit : in out Boolean);
procedure Value (Item : in String; Quit : in out Boolean);
-----------------
-- Named_Value --
-----------------
procedure Named_Value (Name, Value : in String; Quit : in out Boolean) is
begin
if (Name = "q" or Name = "Q") and Float'Value (Value) = 0.0 then
if Found_Encoding then
-- Encoding is disabled by encoding;q=0;
Enable_Encoding := False;
Quit := True;
elsif Just_Found_Others then
Enable_Others := False;
end if;
end if;
end Named_Value;
-----------
-- Value --
-----------
procedure Value (Item : in String; Quit : in out Boolean) is
begin
if Found_Encoding then
if Enable_Encoding then
Quit := True;
return;
else
-- Encoding is enable if qvalue is not specified.
Enable_Encoding := True;
end if;
end if;
Found_Encoding := To_Lower (Item) = Encoding_Image;
Just_Found_Others := Item = "*";
if Just_Found_Others and not Found_Others then
Found_Others := True;
end if;
end Value;
procedure Parse is new Headers.Values.Parse (Value, Named_Value);
use type Messages.Content_Encoding;
begin
for
K in 1 .. Headers.Count (D.Header, Messages.Accept_Encoding_Token)
loop
Parse (Headers.Get (D.Header, Messages.Accept_Encoding_Token, K));
end loop;
return (Found_Encoding and Enable_Encoding)
or else
(not Found_Encoding and Found_Others and Enable_Others)
or else
(Encoding = Messages.Identity and Enable_Others);
end Is_Supported;
----------------
-- Keep_Alive --
----------------
function Keep_Alive (D : in Data) return Boolean is
begin
return D.Keep_Alive;
end Keep_Alive;
------------
-- Method --
------------
function Method (D : in Data) return Request_Method is
begin
return D.Method;
end Method;
------------------------
-- Multipart_Boundary --
------------------------
function Multipart_Boundary (D : in Data) return String is
use Headers;
begin
-- Get the Boundary value from the Contant_Type header value.
-- We do not need to have the boundary in the Status.Data pre-parsed,
-- because AWS is not using function Multipart_Boundary internally.
return Values.Search
(Get (D.Header, Messages.Content_Type_Token),
"Boundary", Case_Sensitive => False);
end Multipart_Boundary;
----------------
-- Parameters --
----------------
function Parameters (D : in Data) return AWS.Parameters.List is
begin
return D.Parameters;
end Parameters;
-------------
-- Payload --
-------------
function Payload (D : in Data) return String is
begin
if D.SOAP_Action then
return Translator.To_String (D.Binary_Data.all);
else
return "";
end if;
end Payload;
--------------
-- Peername --
--------------
function Peername (D : in Data) return String is
begin
return To_String (D.Peername);
end Peername;
----------------------
-- Preferred_Coding --
----------------------
function Preferred_Coding (D : in Data) return Messages.Content_Encoding is
Best_Encoding : Messages.Content_Encoding := Messages.Identity;
Next_Encoding : Messages.Content_Encoding;
Supported : Boolean := False;
-- Next coding supported by AWS.
Best_QValue : Float := 0.0;
Next_QValue : Float;
procedure Named_Value (Name, Value : in String; Quit : in out Boolean);
procedure Value (Item : in String; Quit : in out Boolean);
-----------------
-- Named_Value --
-----------------
procedure Named_Value (Name, Value : in String; Quit : in out Boolean) is
pragma Unreferenced (Quit);
begin
if Supported and (Name = "Q" or Name = "q") then
Next_QValue := Float'Value (Value);
end if;
end Named_Value;
-----------
-- Value --
-----------
procedure Value (Item : in String; Quit : in out Boolean) is
begin
if Supported and Next_QValue > Best_QValue then
Best_Encoding := Next_Encoding;
Best_QValue := Next_QValue;
if Best_QValue = 1.0 then
-- Could not be more then 1.
Quit := True;
return;
end if;
end if;
begin
Next_Encoding := Messages.Content_Encoding'Value (Item);
Next_QValue := 1.0; -- Default qvalue.
Supported := True;
exception
when Constraint_Error =>
Supported := False;
end;
end Value;
procedure Parse is new Headers.Values.Parse (Value, Named_Value);
begin
for
K in 1 .. Headers.Count (D.Header, Messages.Accept_Encoding_Token)
loop
Parse (Headers.Get (D.Header, Messages.Accept_Encoding_Token, K));
end loop;
if Supported and Next_QValue > Best_QValue then
Best_Encoding := Next_Encoding;
Best_QValue := Next_QValue;
end if;
return Best_Encoding;
end Preferred_Coding;
-------------
-- Referer --
-------------
function Referer (D : in Data) return String is
begin
return Headers.Get (D.Header, Messages.Referer_Token);
end Referer;
-------------
-- Session --
-------------
function Session (D : in Data) return AWS.Session.ID is
use Ada.Exceptions;
begin
if Has_Session (D) then
return D.Session_ID;
else
Raise_Exception
(Constraint_Error'Identity,
Message => "Can't use AWS session feature "
& "if session support not activated.");
end if;
end Session;
---------------------
-- Session_Created --
---------------------
function Session_Created (D : in Data) return Boolean is
begin
return D.Session_Created;
end Session_Created;
----------------
-- SOAPAction --
----------------
function SOAPAction (D : in Data) return String is
Result : constant String
:= Headers.Get (D.Header, Messages.SOAPAction_Token);
begin
if Result'First < Result'Last
and then Result (Result'First) = '"'
and then Result (Result'Last) = '"'
then
return Result (Result'First + 1 .. Result'Last - 1);
else
return Result;
end if;
end SOAPAction;
------------
-- Socket --
------------
function Socket (D : in Data) return Net.Socket_Type'Class is
begin
return D.Socket.all;
end Socket;
---------
-- URI --
---------
function URI (D : in Data) return String is
begin
return URL.URL (D.URI);
end URI;
function URI (D : in Data) return URL.Object
is
begin
return D.URI;
end URI;
----------------
-- User_Agent --
----------------
function User_Agent (D : in Data) return String is
begin
return Headers.Get (D.Header, Messages.User_Agent_Token);
end User_Agent;
end AWS.Status;