------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T . C G I . C O O K I E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2003 Ada Core Technologies, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT 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 distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 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. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Fixed; with Ada.Strings.Maps; with Ada.Text_IO; with Ada.Integer_Text_IO; with GNAT.Table; package body GNAT.CGI.Cookie is use Ada; Valid_Environment : Boolean := False; -- This boolean will be set to True if the initialization was fine. Header_Sent : Boolean := False; -- Will be set to True when the header will be sent. -- Cookie data that have been added. type String_Access is access String; type Cookie_Data is record Key : String_Access; Value : String_Access; Comment : String_Access; Domain : String_Access; Max_Age : Natural; Path : String_Access; Secure : Boolean := False; end record; type Key_Value is record Key, Value : String_Access; end record; package Cookie_Table is new Table (Cookie_Data, Positive, 1, 5, 50); -- This is the table to keep all cookies to be sent back to the server. package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50); -- This is the table to keep all cookies received from the server. procedure Check_Environment; pragma Inline (Check_Environment); -- This procedure will raise Data_Error if Valid_Environment is False. procedure Initialize; -- Initialize CGI package by reading the runtime environment. This -- procedure is called during elaboration. All exceptions raised during -- this procedure are deferred. ----------------------- -- Check_Environment -- ----------------------- procedure Check_Environment is begin if not Valid_Environment then raise Data_Error; end if; end Check_Environment; ----------- -- Count -- ----------- function Count return Natural is begin return Key_Value_Table.Last; end Count; ------------ -- Exists -- ------------ function Exists (Key : String) return Boolean is begin Check_Environment; for K in 1 .. Key_Value_Table.Last loop if Key_Value_Table.Table (K).Key.all = Key then return True; end if; end loop; return False; end Exists; ---------------------- -- For_Every_Cookie -- ---------------------- procedure For_Every_Cookie is Quit : Boolean; begin Check_Environment; for K in 1 .. Key_Value_Table.Last loop Quit := False; Action (Key_Value_Table.Table (K).Key.all, Key_Value_Table.Table (K).Value.all, K, Quit); exit when Quit; end loop; end For_Every_Cookie; ---------------- -- Initialize -- ---------------- procedure Initialize is HTTP_COOKIE : constant String := Metavariable (CGI.HTTP_Cookie); procedure Set_Parameter_Table (Data : String); -- Parse Data and insert information in Key_Value_Table. ------------------------- -- Set_Parameter_Table -- ------------------------- procedure Set_Parameter_Table (Data : String) is procedure Add_Parameter (K : Positive; P : String); -- Add a single parameter into the table at index K. The parameter -- format is "key=value". Count : constant Positive := 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set (";")); -- Count is the number of parameters in the string. Parameters are -- separated by ampersand character. Index : Positive := Data'First; Sep : Natural; ------------------- -- Add_Parameter -- ------------------- procedure Add_Parameter (K : Positive; P : String) is Equal : constant Natural := Strings.Fixed.Index (P, "="); begin if Equal = 0 then raise Data_Error; else Key_Value_Table.Table (K) := Key_Value'(new String'(Decode (P (P'First .. Equal - 1))), new String'(Decode (P (Equal + 1 .. P'Last)))); end if; end Add_Parameter; begin Key_Value_Table.Set_Last (Count); for K in 1 .. Count - 1 loop Sep := Strings.Fixed.Index (Data (Index .. Data'Last), ";"); Add_Parameter (K, Data (Index .. Sep - 1)); Index := Sep + 2; end loop; -- add last parameter Add_Parameter (Count, Data (Index .. Data'Last)); end Set_Parameter_Table; begin if HTTP_COOKIE /= "" then Set_Parameter_Table (HTTP_COOKIE); end if; Valid_Environment := True; exception when others => Valid_Environment := False; end Initialize; --------- -- Key -- --------- function Key (Position : Positive) return String is begin Check_Environment; if Position <= Key_Value_Table.Last then return Key_Value_Table.Table (Position).Key.all; else raise Cookie_Not_Found; end if; end Key; -------- -- Ok -- -------- function Ok return Boolean is begin return Valid_Environment; end Ok; ---------------- -- Put_Header -- ---------------- procedure Put_Header (Header : String := Default_Header; Force : Boolean := False) is procedure Output_Cookies; -- Iterate through the list of cookies to be sent to the server -- and output them. -------------------- -- Output_Cookies -- -------------------- procedure Output_Cookies is procedure Output_One_Cookie (Key : String; Value : String; Comment : String; Domain : String; Max_Age : Natural; Path : String; Secure : Boolean); -- Output one cookie in the CGI header. ----------------------- -- Output_One_Cookie -- ----------------------- procedure Output_One_Cookie (Key : String; Value : String; Comment : String; Domain : String; Max_Age : Natural; Path : String; Secure : Boolean) is begin Text_IO.Put ("Set-Cookie: "); Text_IO.Put (Key & '=' & Value); if Comment /= "" then Text_IO.Put ("; Comment=" & Comment); end if; if Domain /= "" then Text_IO.Put ("; Domain=" & Domain); end if; if Max_Age /= Natural'Last then Text_IO.Put ("; Max-Age="); Integer_Text_IO.Put (Max_Age, Width => 0); end if; if Path /= "" then Text_IO.Put ("; Path=" & Path); end if; if Secure then Text_IO.Put ("; Secure"); end if; Text_IO.New_Line; end Output_One_Cookie; -- Start of processing for Output_Cookies begin for C in 1 .. Cookie_Table.Last loop Output_One_Cookie (Cookie_Table.Table (C).Key.all, Cookie_Table.Table (C).Value.all, Cookie_Table.Table (C).Comment.all, Cookie_Table.Table (C).Domain.all, Cookie_Table.Table (C).Max_Age, Cookie_Table.Table (C).Path.all, Cookie_Table.Table (C).Secure); end loop; end Output_Cookies; -- Start of processing for Put_Header begin if Header_Sent = False or else Force then Check_Environment; Text_IO.Put_Line (Header); Output_Cookies; Text_IO.New_Line; Header_Sent := True; end if; end Put_Header; --------- -- Set -- --------- procedure Set (Key : String; Value : String; Comment : String := ""; Domain : String := ""; Max_Age : Natural := Natural'Last; Path : String := "/"; Secure : Boolean := False) is begin Cookie_Table.Increment_Last; Cookie_Table.Table (Cookie_Table.Last) := Cookie_Data'(new String'(Key), new String'(Value), new String'(Comment), new String'(Domain), Max_Age, new String'(Path), Secure); end Set; ----------- -- Value -- ----------- function Value (Key : String; Required : Boolean := False) return String is begin Check_Environment; for K in 1 .. Key_Value_Table.Last loop if Key_Value_Table.Table (K).Key.all = Key then return Key_Value_Table.Table (K).Value.all; end if; end loop; if Required then raise Cookie_Not_Found; else return ""; end if; end Value; function Value (Position : Positive) return String is begin Check_Environment; if Position <= Key_Value_Table.Last then return Key_Value_Table.Table (Position).Value.all; else raise Cookie_Not_Found; end if; end Value; -- Elaboration code for package begin -- Initialize unit by reading the HTTP_COOKIE metavariable and fill -- Key_Value_Table structure. Initialize; end GNAT.CGI.Cookie;