File : src/aws-headers-values.adb


------------------------------------------------------------------------------
--                              Ada Web Server                              --
--                                                                          --
--                          Copyright (C) 2002-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-headers-values.adb,v 1.12 2003/09/23 05:49:05 anisimko Exp $

with Ada.Exceptions;
with Ada.Strings.Fixed;
with Ada.Strings.Maps.Constants;

package body AWS.Headers.Values is

   use Ada.Strings;

   Spaces : constant Maps.Character_Set
     := Maps.To_Set (' ' & ASCII.HT & ASCII.LF & ASCII.CR);
   --  Set of spaces to ignore during parsing

   procedure Next_Value
      (Data        : in     String;
       First       : in out Natural;
       Name_First  :    out Positive;
       Name_Last   :    out Natural;
       Value_First :    out Positive;
       Value_Last  :    out Natural);
   --  Returns the next named or un-named value from Data. It start the search
   --  from First index. Returns First = 0 if it has reached the end of
   --  Data. Returns Name_Last = 0 if an un-named value has been found.

   -----------------------
   -- Get_Unnamed_Value --
   -----------------------

   function Get_Unnamed_Value
     (Header_Value : in String;
      N            : in Positive := 1)
      return String
   is
      First       : Natural;
      Name_First  : Positive;
      Name_Last   : Natural;
      Value_First : Positive;
      Value_Last  : Natural;

      Count       : Natural := 0;

   begin
      First := Fixed.Index
        (Source => Header_Value,
         Set    => Spaces,
         Test   => Outside);

      if First = 0 then
         --  Value is empty or contains only spaces
         return "";
      end if;

      loop
         Next_Value
           (Header_Value, First,
            Name_First, Name_Last,
            Value_First, Value_Last);

         if Name_Last = 0 then
            Count := Count + 1;

            if Count = N then
               return Header_Value (Value_First .. Value_Last);
            end if;
         end if;

         exit when First = 0;
      end loop;

      --  There is not such value, return the empty string
      return "";
   end Get_Unnamed_Value;

   ------------
   --  Index --
   ------------

   function Index
     (Set            : in Values.Set;
      Name           : in String;
      Case_Sensitive : in Boolean := True)
      return Natural
   is
      Map    : Maps.Character_Mapping;
      M_Name : Unbounded_String;
   begin
      if Case_Sensitive then
         Map    := Maps.Identity;
         M_Name := To_Unbounded_String (Name);
      else
         Map    := Maps.Constants.Upper_Case_Map;
         M_Name := Translate (To_Unbounded_String (Name), Map);
      end if;

      for I in Set'Range loop
         if Set (I).Named_Value
           and then Translate (Set (I).Name, Map) = M_Name
         then
            return I;
         end if;
      end loop;

      --  Name was not found, return 0
      return 0;
   end Index;

   ----------------
   -- Next_Value --
   ----------------

   procedure Next_Value
     (Data        : in     String;
      First       : in out Natural;
      Name_First  :    out Positive;
      Name_Last   :    out Natural;
      Value_First :    out Positive;
      Value_Last  :    out Natural)
   is
      use type Maps.Character_Set;

      EDel   : constant Maps.Character_Set := Maps.To_Set (" ,;");
      --  Delimiter between name/value pairs in the HTTP header lines.
      --  In WWW-Authenticate, header delimiter between name="Value"
      --  pairs is a comma.
      --  In the Set-Cookie header, value delimiter between name="Value"
      --  pairs is a semi-colon.

      NVDel  : constant Character := '=';
      --  Delimiter between name and Value for a named value

      VDel   : constant Maps.Character_Set := EDel or Maps.To_Set (NVDel);
      --  Delimiter between name and value is '=' and it is a space between
      --  un-named values.

      Last   : Natural;

   begin
      Last := Fixed.Index (Data (First .. Data'Last), VDel);

      Name_Last := 0;

      if Last = 0 then
         --  This is the last single value.

         Value_First := First;
         Value_Last  := Data'Last;
         First       := 0; -- Mean end of line

      elsif Data (Last) = '=' then
         --  Here we have a named value

         Name_First := First;
         Name_Last  := Last - 1;
         First      := Last + 1;

         --  Check if this is a quoted or unquoted value

         if First < Data'Last and then Data (First) = '"' then
            --  Quoted value

            Value_First := First + 1;

            Last := Fixed.Index (Data (Value_First .. Data'Last), """");

            if Last = 0 then
               --  Format error as there is no closing quote

               Ada.Exceptions.Raise_Exception
                 (Format_Error'Identity,
                  "HTTP header line format error : " & Data);
            else
               Value_Last := Last - 1;
            end if;

            First := Last + 2;

         else
            --  Unquoted value

            Value_First := First;

            Last := Ada.Strings.Fixed.Index (Data (First .. Data'Last), EDel);

            if Last = 0 then
               Value_Last := Data'Last;
               First      := 0;
            else
               Value_Last := Last - 1;
               First      := Last + 1;
            end if;
         end if;
      else
         --  This is an un-named value

         Value_First := First;
         Value_Last  := Last - 1;
         First       := Last + 1;

         --  Do not return the delimiter as part of the value

         while Maps.Is_In (Data (Value_Last), EDel) loop
            Value_Last := Value_Last - 1;
         end loop;

      end if;

      if First > Data'Last then
         --  We have reached the end-of-line
         First := 0;

      elsif First > 0 then
         --  Ignore the next leading spaces

         First := Fixed.Index
            (Source => Data (First .. Data'Last),
             Set    => Spaces,
             Test   => Outside);
      end if;
   end Next_Value;

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

   procedure Parse (Header_Value : in String) is

      First       : Natural;
      Name_First  : Positive;
      Name_Last   : Natural;
      Value_First : Positive;
      Value_Last  : Natural;
      Quit        : Boolean;

   begin
      --  Ignore the leading spaces

      First := Fixed.Index
        (Source => Header_Value,
         Set    => Spaces,
         Test   => Outside);

      if First = 0 then
         --  Value is empty or contains only spaces
         return;
      end if;

      loop
         Next_Value
           (Header_Value, First,
            Name_First,  Name_Last,
            Value_First, Value_Last);

         Quit := False;

         if Name_Last > 0 then
            Named_Value
              (Header_Value (Name_First .. Name_Last),
               Header_Value (Value_First .. Value_Last),
               Quit);
         else
            Value
              (Header_Value (Value_First .. Value_Last),
               Quit);
         end if;

         exit when Quit or else First = 0;

      end loop;
   end Parse;

   ------------
   -- Search --
   ------------

   function Search
     (Header_Value   : in String;
      Name           : in String;
      Case_Sensitive : in Boolean := True)
      return String
   is
      First       : Natural;
      Name_First  : Positive;
      Name_Last   : Natural;
      Value_First : Positive;
      Value_Last  : Natural;

      Map         : Maps.Character_Mapping;

      M_Name      : String (Name'Range);
      --  Mapped name

   begin
      First := Fixed.Index
        (Source => Header_Value,
         Set    => Spaces,
         Test   => Outside);

      if First = 0 then
         --  Value is empty or contains only spaces
         return "";
      end if;

      if Case_Sensitive then
         Map    := Maps.Identity;
         M_Name := Name;
      else
         Map    := Maps.Constants.Upper_Case_Map;
         M_Name := Fixed.Translate (Name, Map);
      end if;

      loop
         Next_Value
           (Header_Value, First,
            Name_First, Name_Last,
            Value_First, Value_Last);

         if Name_Last > 0
              and then
           M_Name =
             Fixed.Translate (Header_Value (Name_First .. Name_Last), Map)
         then
            return Header_Value (Value_First .. Value_Last);
         end if;

         exit when First = 0;
      end loop;

      --  Name not found, returns the empty string
      return "";
   end Search;

   -----------
   -- Split --
   -----------

   function Split (Header_Value : in String) return Set is

      First    : Natural;
      Null_Set : Set (1 .. 0);

      function To_Set return Set;
      --  Parse the Header_Value and return a set of named and un-named
      --  value. Note that this routine is recursive as the final Set size is
      --  not known. This should not be a problem as the number of token on an
      --  Header_Line is quite small.

      ------------
      -- To_Set --
      ------------

      function To_Set return Set is

         Name_First  : Positive;
         Name_Last   : Natural;
         Value_First : Positive;
         Value_Last  : Natural;

         function Element return Data;
         --  Returns the Data element from the substrings defined by
         --  Name_First, Name_Last, Value_First, Value_Last.

         -------------
         -- Element --
         -------------

         function Element return Data is
            function "+"
              (Item : in String)
               return Unbounded_String
              renames To_Unbounded_String;
         begin
            if Name_Last = 0 then
               return Data'
                 (Named_Value => False,
                  Value => +Header_Value (Value_First .. Value_Last));
            else
               return Data'
                  (True,
                   Name  => +Header_Value (Name_First .. Name_Last),
                   Value => +Header_Value (Value_First .. Value_Last));
            end if;
         end Element;

      begin
         if First = 0 then
            --  This is the end of recursion.
            return Null_Set;
         end if;

         Next_Value
           (Header_Value, First,
            Name_First, Name_Last,
            Value_First, Value_Last);

         return Element & To_Set;
      end To_Set;

   begin
      First := Fixed.Index
        (Source => Header_Value,
         Set    => Spaces,
         Test   => Outside);

      return To_Set;
   end Split;

   --------------------------
   -- Unnamed_Value_Exists --
   --------------------------

   function Unnamed_Value_Exists
     (Header_Value   : in String;
      Value          : in String;
      Case_Sensitive : in Boolean := True)
      return Boolean
   is
      First       : Natural;
      Name_First  : Positive;
      Name_Last   : Natural;
      Value_First : Positive;
      Value_Last  : Natural;

      Map     : Maps.Character_Mapping;
      M_Value : String (Value'Range);

   begin
      First := Fixed.Index
        (Source => Header_Value,
         Set    => Spaces,
         Test   => Outside);

      if First = 0 then
         --  Value is empty or contains only spaces
         return False;
      end if;

      if Case_Sensitive then
         Map     := Maps.Identity;
         M_Value := Value;
      else
         Map     := Maps.Constants.Upper_Case_Map;
         M_Value := Fixed.Translate (Value, Map);
      end if;

      loop
         Next_Value
           (Header_Value, First,
            Name_First, Name_Last,
            Value_First, Value_Last);

         if Name_Last = 0
           and then M_Value = Fixed.Translate
              (Header_Value (Value_First .. Value_Last), Map)
         then
            return True;
         end if;

         exit when First = 0;
      end loop;

      --  There is not such value
      return False;
   end Unnamed_Value_Exists;

end AWS.Headers.Values;