Re: cookies

["Pascal Obry" <p.obry@der.edf.fr>]

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain, Size: 12086 bytes --]


Lisa Winkworth a �crit dans le message <6tpv6c$o1l$1@emu.cs.rmit.edu.au>...
>Hi, does anyone have any idea how to accept/generally do stuff with cookies
>in ada95??
>Any help would be much appreciated :)
>Thanks in advance,
>Lisa
>


Lisa,

I have done a child package of cgi.ads (from David A. Wheeler) to handle
cookies.

The packages spec/body are small so I have included them in this message.

Pascal.

---------------------------------- CUT
HERE -----------------------------------------------

--         File Name : cgi-cookies.ads
--
--       Created by  : Pascal Obry
--               on  : Mon Mar 10 16:05:01 1997

with Ada.Strings.Unbounded;

package CGI.Cookies is

   use Ada.Strings.Unbounded;

   --  Get cookie number
   function Count return Natural;


   --  Get cookies value
   function Value
     (Key      : in Unbounded_String;
      Required : in Boolean          := False)
      return Unbounded_String;

   function Value
     (Key      : in String;
      Required : in Boolean := False)
      return Unbounded_String;

   function Value
     (Key      : in String;
      Required : in Boolean := False)
      return String;

   function Value
     (Key      : in Unbounded_String;
      Required : in Boolean          := False)
      return String;


   --  Was a given key provided?
   function Key_Exists (Key : in String)           return Boolean;
   function Key_Exists (Key : in Unbounded_String) return Boolean;


   --  Set cookies value
   procedure Set (Key     : in String;
                  Value   : in String;
                  Expires : in String  := "";
                  Path    : in String  := "/";
                  Domain  : in String  := "";
                  Secure  : in Boolean := False);


   --  Send cookies to client with HTML header.
   procedure Put_CGI_Header_With_Cookies
     (Header : in String := "Content-type: text/html");

end CGI.Cookies;


--         File Name : cgi-cookies.adb
--
--       Created by  : Pascal Obry
--               on  : Mon Mar 10 16:05:01 1997

with Ada.Text_IO;
with Ada.Strings.Maps;
with Ada.Characters.Handling;

with Table_Of_Static_Keys_And_Static_Values_G;

package body CGI.Cookies is

   use Ada;
   use Ada.Strings.Maps;

   --  to set cookie
   type Key_Values_Record is
      record
         Value   : Unbounded_String;
         Expires : Unbounded_String;
         Path    : Unbounded_String;
         Domain  : Unbounded_String;
         Secure  : Boolean := False;
      end record;

   package Cookie_Table is
      new Table_Of_Static_Keys_And_Static_Values_G (Unbounded_String,
                                                    "<",
                                                    "=",
                                                    Key_Values_Record);

   --  to hold cookie value sent be the client
   type Key_Value_Pair is
      record
         Key   : Unbounded_String;
         Value : Unbounded_String;
      end record;

   type Key_Value_Sequence is array (Positive range <>) of Key_Value_Pair;
   type Access_Key_Value_Sequence is access Key_Value_Sequence;

   -- The following are data internal to this package.

   Cookie_Data     : Access_Key_Value_Sequence;

   Set_Cookie_Data : Cookie_Table.Table_Type;


   Ampersands :    constant Character_Set      := To_Set ('&');
   Equals     :    constant Character_Set      := To_Set ('=');
   Plus_To_Space : constant Character_Mapping  := To_Mapping ("+", " ");


                      ------------------------------

   --  Get cookie number
   function Count return Natural is
   begin
      if Cookie_Data = null then
         return 0;
      else
         return Cookie_Data'Length;
      end if;
   end Count;
                      ------------------------------


   --  Get cookies value
   function Value
     (Key      : in Unbounded_String;
      Required : in Boolean          := False)
      return Unbounded_String is
   begin
      for I in 1 .. Count loop
         if Cookie_Data (I).Key = Key then
            return Cookie_Data (I).Value;
         end if;
      end loop;

      -- Didn't find the Key.
      if Required then
         raise Constraint_Error;
      else
         return Null_Unbounded_String;
      end if;
   end Value;

                      ------------------------------

   function Value
     (Key      : in String;
      Required : in Boolean := False)
      return Unbounded_String
   is
   begin
      return Value (To_Unbounded_String (Key), Required);
   end Value;

                      ------------------------------

   function Value
     (Key      : in String;
      Required : in Boolean := False)
      return String
   is
   begin
      return To_String (Value (To_Unbounded_String (Key), Required));
   end Value;

                      ------------------------------

   function Value
     (Key      : in Unbounded_String;
      Required : in Boolean          := False)
      return String
   is
   begin
      return To_String (Value (Key, Required));
   end Value;


                      ------------------------------

   --  Was a given key provided?
   function Key_Exists (Key : in Unbounded_String)
                        return Boolean
   is
   begin
      for I in 1 .. Count loop
         if Cookie_Data (I).Key = Key then
            return True;
         end if;
      end loop;
      return False;
   end Key_Exists;

                      ------------------------------

   function Key_Exists (Key : in String)
                        return Boolean
   is
   begin
     return Key_Exists (To_Unbounded_String (Key));
   end Key_Exists;


                      ------------------------------

   --  Set cookie value
   procedure Set (Key     : in String;
                  Value   : in String;
                  Expires : in String := "";
                  Path    : in String := "/";
                  Domain  : in String := "";
                  Secure  : in Boolean := False)
   is
      Cookie_Record : Key_Values_Record;
   begin -- Set_Cookies
      Cookie_Record := (To_Unbounded_String (Value),
                        To_Unbounded_String (Expires),
                        To_Unbounded_String (Path),
                        To_Unbounded_String (Domain),
                        Secure);

      Cookie_Table.Insert_Or_Replace_Value (Set_Cookie_Data,
                                            To_Unbounded_String (Key),
                                            Cookie_Record);
   end Set;


                      ------------------------------

   procedure Put_CGI_Header_With_Cookies
     (Header : in String := "Content-type: text/html")
   is

      procedure Put_Cookie (Key      : in     Unbounded_String;
                            Datas    : in     Key_Values_Record;
                            N        : in     Positive;
                            Continue : in out Boolean) is
      begin
         Text_IO.Put ("Set-Cookie: ");
         Text_IO.Put (To_String (Key) & '=' & To_String (Datas.Value));

         if Datas.Expires /= Null_Unbounded_String then
            Text_IO.Put ("; expires=" & To_String (Datas.Expires));
         end if;

         if Datas.Path /= Null_Unbounded_String then
            Text_IO.Put ("; path=" & To_String (Datas.Path));
         end if;

         if Datas.Domain /= Null_Unbounded_String then
            Text_IO.Put ("; domain=" & To_String (Datas.Domain));
         end if;

         if Datas.Secure then
            Text_IO.Put ("; secure");
         end if;

         Text_IO.New_Line;

         Continue := True;
      end Put_Cookie;


      procedure For_Every_Cookies is
         new Cookie_Table.Traverse_ASC_G (Put_Cookie);

   begin
      --  CGI Header
      Text_IO.Put_Line (Header);

      --  Cookies
      For_Every_Cookies (Set_Cookie_Data);
      Text_IO.New_Line;
   end Put_CGI_Header_With_Cookies;





                      ------------------------------

   -- Initialization routines, including some private procedures only
   -- used during initialization.

   function Field_End
     (Data            : Unbounded_String;
      Field_Separator : Character;
      Starting_At     : Positive         := 1)
      return Natural
   is
      -- Return the end-of-field position in Data after "Starting_Index",
      -- assuming that fields are separated by the Field_Separator.
      -- If there's no Field_Separator, return the end of the Data.
   begin
      for I in Starting_At .. Length (Data) loop
         if Element (Data, I) = Field_Separator then
            return I - 1;
         end if;
      end loop;
      return Length (Data);
   end Field_End;

                      ------------------------------

   function Hex_Value (H : in String) return Natural is
      -- Given hex string, return its Value as a Natural.
      Value : Natural := 0;
   begin
      for P in 1.. H'Length loop
         Value := Value * 16;

         if H(P) in '0' .. '9' then
            Value := Value + Character'Pos(H(P)) - Character'Pos('0');
         elsif H(P) in 'A' .. 'F' then
            Value := Value + Character'Pos(H(P)) - Character'Pos('A') + 10;
         elsif H(P) in 'a' .. 'f' then
            Value := Value + Character'Pos(H(P)) - Character'Pos('a') + 10;
         else
            raise Constraint_Error;
         end if;

      end loop;
      return Value;
   end Hex_Value;

                      ------------------------------

   procedure Decode (Data : in out Unbounded_String)
   is
      use Characters.Handling;
      I : Positive := 1;
      -- In the given string, convert pattern %HH into alphanumeric
characters,
      -- where HH is a hex number. Since this encoding only permits values
      -- from %00 to %FF, there's no need to handle 16-bit characters.
   begin
      while I <= Length(Data) - 2 loop
         if Element (Data, I) = '%' and
           Is_Hexadecimal_Digit (Element (Data, I+1)) and
           Is_Hexadecimal_Digit (Element (Data, I+2)) then

            Replace_Element
              (Data, I,
               Character'Val (Hex_Value (Slice (Data, I+1, I+2))));
            Delete (Data, I+1, I+2);
         end if;
         I := I + 1;
      end loop;
   end Decode;
                      ------------------------------

   procedure Set_CGI_Position
     (Key_Number : in Positive;
      Datum      : in Unbounded_String)
   is
      Last : Natural := Field_End(Datum, '=');
      -- Given a Key number and a datum of the form key=value
      -- assign the CGI_Data(Key_Number) the values of key and value.
   begin
      Cookie_Data (Key_Number).Key
        := To_Unbounded_String (Slice (Datum, 1, Last));
      Cookie_Data (Key_Number).Value
        := To_Unbounded_String (Slice (Datum, Last+2, Length (Datum)));
      Decode (Cookie_Data (Key_Number).Key);
      Decode (Cookie_Data (Key_Number).Value);
   end Set_CGI_Position;

                      ------------------------------

   procedure Set_CGI_Data (Raw_Data : in Unbounded_String) is
      -- Set CGI_Data using Raw_Data.
      Key_Number         : Positive := 1;
      Character_Position : Positive := 1;
      Last : Natural;
   begin
      while Character_Position <= Length (Raw_Data) loop
         Last := Field_End (Raw_Data, ';', Character_Position);
         Set_CGI_Position
           (Key_Number,
            To_Unbounded_String (Slice (Raw_Data, Character_Position,
Last)));
         Character_Position := Last + 3; -- Skip over field separator. "; "
         Key_Number := Key_Number + 1;
      end loop;
   end Set_CGI_Data;

                      ------------------------------

   procedure Initialize is
      Raw_Data : Unbounded_String;
   begin
      Raw_Data := To_Unbounded_String (Get_Environment("HTTP_COOKIE"));

      Translate (Raw_Data, Mapping => Plus_To_Space);

      if Length (Raw_Data) > 0 then
         Cookie_Data :=
           new Key_Value_Sequence (1 .. Count (Raw_Data, ";") + 1);
         Set_CGI_Data (Raw_Data);
      end if;

   end Initialize;

begin
   Initialize;
end CGI.Cookies;
---------------------------------- CUT
HERE -----------------------------------------------