File : src/aws-status-set.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-set.adb,v 1.36 2003/10/06 17:01:59 obry Exp $

with Ada.Characters.Handling;
with Ada.Exceptions;
with Ada.Strings.Fixed;

with AWS.Headers.Set;
with AWS.Headers.Values;
with AWS.Messages;
with AWS.Translator;
with AWS.Parameters.Set;

package body AWS.Status.Set is

   use Ada.Strings;

   procedure Authorization (D : in out Data);
   --  Parse the Authorization parameters from the Authorization header value.

   procedure Update_Data_From_Header (D : in out Data);
   --  Update some Data fields from the internal Data header container.
   --  The Update_Data_From_Header should be called after the complete
   --  header parsing.

   -------------------
   -- Authorization --
   -------------------

   procedure Authorization (D : in out Data) is

      Header_Value : constant String
        := AWS.Headers.Get (D.Header, Messages.Authorization_Token);

      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

         type Digest_Attribute
            is (Username, Realm, Nonce, NC, CNonce,
                QOP, URI, Response, Algorithm);
         --  The enumeration type is using to be able to
         --  use the name in the case statement.
         --  The case statement has usially faster implementation.

         Attribute : Digest_Attribute;

         function "+"
           (Item : in String)
            return Unbounded_String
           renames To_Unbounded_String;

      begin
         begin
            Attribute := Digest_Attribute'Value (Name);
         exception
            when Constraint_Error =>
               --  Ignoring unrecognized attribute
               return;
         end;

         --  Check if the attributes is for the Digest authenticatio schema.
         --  AWS does not support othe authentication schemas with attributes
         --  now.
         if D.Auth_Mode /= Digest then
            Quit := True;
         end if;

         case Attribute is
            when Username  => D.Auth_Name     := +Value;
            when Realm     => D.Auth_Realm    := +Value;
            when NC        => D.Auth_NC       := +Value;
            when CNonce    => D.Auth_CNonce   := +Value;
            when QOP       => D.Auth_QOP      := +Value;
            when Nonce     => D.Auth_Nonce    := +Value;
            when Response  => D.Auth_Response := +Value;
            when URI       => D.Auth_URI      := +Value;
            when Algorithm =>
               if Value /= "MD5" then
                  Ada.Exceptions.Raise_Exception
                     (Constraint_Error'Identity,
                      "Only MD5 algorithm is supported.");
               end if;
         end case;
      end Named_Value;

      -----------
      -- Value --
      -----------

      procedure Value (Item : in String; Quit : in out Boolean) is
         Upper_Item : constant String
           := Ada.Characters.Handling.To_Upper (Item);
      begin
         if Upper_Item = "BASIC" then

            D.Auth_Mode := Basic;

            Quit := True;

            --  We could not continue to parse Basic authentication
            --  by the regular way, because next value is Base64 encoded
            --  "username:password", it is possibe to have symbol '=' there,
            --  our parser could think that it is name/value delimiter.

            declare
               use Ada.Streams;

               Auth_Str : constant String
                 := Translator.To_String (Translator.Base64_Decode
                   (Header_Value (Item'Length + 2 .. Header_Value'Last)));

               Delimit  : constant Natural := Fixed.Index (Auth_Str, ":");
            begin
               if Delimit = 0 then
                  D.Auth_Name := To_Unbounded_String (Auth_Str);

               else
                  D.Auth_Name
                    := To_Unbounded_String (Auth_Str (1 .. Delimit - 1));
                  D.Auth_Password
                    := To_Unbounded_String
                         (Auth_Str (Delimit + 1 .. Auth_Str'Last));
               end if;
            end;

         elsif Upper_Item = "DIGEST" then
            D.Auth_Mode := Digest;

         end if;
      end Value;

      procedure Parse is new Headers.Values.Parse (Value, Named_Value);

   begin
      Parse (Header_Value);
   end Authorization;

   ------------
   -- Binary --
   ------------

   procedure Binary
     (D         : in out Data;
      Parameter : in     Stream_Element_Array) is
   begin
      D.Binary_Data := new Stream_Element_Array'(Parameter);
   end Binary;

   ----------
   -- Free --
   ----------

   procedure Free (D : in out Data) is
   begin
      Utils.Free (D.Binary_Data);

      AWS.Parameters.Set.Free (D.Parameters);
      AWS.Headers.Set.Free (D.Header);
   end Free;

   ----------------
   -- Keep_Alive --
   ----------------

   procedure Keep_Alive
     (D    : in out Data;
      Flag : in     Boolean) is
   begin
      D.Keep_Alive := Flag;
   end Keep_Alive;

   ----------------
   -- Parameters --
   ----------------

   procedure Parameters (D : in out Data; Set : in AWS.Parameters.List) is
   begin
      D.Parameters := Set;
   end Parameters;

   --------------
   -- Peername --
   --------------

   procedure Peername
     (D        : in out Data;
      Peername : in     String) is
   begin
      D.Peername := To_Unbounded_String (Peername);
   end Peername;

   -----------------
   -- Read_Header --
   -----------------

   procedure Read_Header
     (Socket : in     Net.Socket_Type'Class;
      D      : in out Data) is
   begin
      Headers.Set.Read (Socket, D.Header);
      Update_Data_From_Header (D);
   end Read_Header;

   -------------
   -- Request --
   -------------

   procedure Request
     (D            : in out Data;
      Method       : in     Request_Method;
      URI          : in     String;
      HTTP_Version : in     String) is
   begin
      D.Method       := Method;
      D.URI          := URL.Parse (URI, False, False);
      D.HTTP_Version := To_Unbounded_String (HTTP_Version);
   end Request;

   -----------
   -- Reset --
   -----------

   procedure Reset (D : in out Data) is
   begin
      Utils.Free (D.Binary_Data);

      D.Method            := GET;
      D.HTTP_Version      := Null_Unbounded_String;
      D.Content_Length    := 0;
      D.Auth_Mode         := None;
      D.Auth_Name         := Null_Unbounded_String;
      D.Auth_Password     := Null_Unbounded_String;
      D.Auth_Realm        := Null_Unbounded_String;
      D.Auth_Nonce        := Null_Unbounded_String;
      D.Auth_NC           := Null_Unbounded_String;
      D.Auth_CNonce       := Null_Unbounded_String;
      D.Auth_QOP          := Null_Unbounded_String;
      D.Auth_URI          := Null_Unbounded_String;
      D.Auth_Response     := Null_Unbounded_String;
      D.Session_ID        := AWS.Session.No_Session;
      D.Session_Created   := False;

      AWS.Parameters.Set.Reset (D.Parameters);
      AWS.Headers.Set.Reset (D.Header);
   end Reset;

   -------------
   -- Session --
   -------------

   procedure Session (D : in out Data) is
   begin
      D.Session_ID      := AWS.Session.Create;
      D.Session_Created := True;
   end Session;

   ------------
   -- Socket --
   ------------

   procedure Socket
     (D    : in out Data;
      Sock : in     Net.Socket_Access) is
   begin
      D.Socket := Sock;
   end Socket;

   -----------------------------
   -- Update_Data_From_Header --
   -----------------------------

   procedure Update_Data_From_Header (D : in out Data) is
   begin
      Authorization (D);

      declare
         Content_Length : constant String := AWS.Headers.Get
           (D.Header, Messages.Content_Length_Token);
      begin
         if Content_Length /= "" then
            D.Content_Length := Integer'Value (Content_Length);
         end if;
      end;

      D.SOAP_Action := AWS.Headers.Exist (D.Header, Messages.SOAPAction_Token);

      declare
         use AWS.Headers;

         Cookies_Set : constant VString_Array
           := Get_Values (D.Header, Messages.Cookie_Token);

      begin
         for Idx in Cookies_Set'Range loop

            declare
               --  The expected Cookie line is:
               --  Cookie: ... AWS=<cookieID>[,;] ...

               use type AWS.Session.ID;

               procedure Value
                 (Item : in     String;
                  Quit : in out Boolean);
               --  Called for every un-named value read from the header value

               procedure Named_Value
                 (Name  : in     String;
                  Value : in     String;
                  Quit  : in out Boolean);
               --  Called for every named value read from the header value

               -----------------
               -- Named_Value --
               -----------------

               procedure Named_Value
                 (Name  : in     String;
                  Value : in     String;
                  Quit  : in out Boolean) is
               begin
                  --  Check if it is AWS Cookie.

                  if Name /= "AWS" then
                     return;
                  end if;

                  D.Session_ID := AWS.Session.Value (Value);

                  --  Check if the cookie value was correct.

                  if D.Session_ID = AWS.Session.No_Session then
                     return;
                  end if;

                  --  Check if cookie exists in the server.

                  if not AWS.Session.Exist (D.Session_ID) then
                     --  Reset to empty cookie if session does not exists.
                     --  We are not interested by non existing values.

                     D.Session_ID := AWS.Session.No_Session;

                     return;
                  end if;

                  --  If all filters done, we found our cookie !
                  Quit := True;
               end Named_Value;

               -----------
               -- Value --
               -----------

               procedure Value
                 (Item : in     String;
                  Quit : in out Boolean)
               is
                  pragma Warnings (Off, Item);
                  pragma Warnings (Off, Quit);
               begin
                  --  Just ignore for now.
                  --  We are looking only for AWS=<cookieID>
                  null;
               end Value;

               -----------
               -- Parse --
               -----------

               procedure Parse is
                  new AWS.Headers.Values.Parse (Value, Named_Value);

            begin
               Parse (To_String (Cookies_Set (Idx)));

               --  Exit when we have found an existing cookie
               exit when D.Session_ID /= AWS.Session.No_Session;
            end;
         end loop;
      end;
   end Update_Data_From_Header;

end AWS.Status.Set;