blob: ffc8edc249c26815eebed457a57ea3c8f0039190 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- 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;