1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . C G I . C O O K I E --
9 -- Copyright (C) 2000-2010, AdaCore --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada.Strings.Fixed;
33 with Ada.Strings.Maps;
35 with Ada.Integer_Text_IO;
39 package body GNAT.CGI.Cookie is
43 Valid_Environment : Boolean := False;
44 -- This boolean will be set to True if the initialization was fine
46 Header_Sent : Boolean := False;
47 -- Will be set to True when the header will be sent
49 -- Cookie data that has been added
51 type String_Access is access String;
53 type Cookie_Data is record
55 Value : String_Access;
56 Comment : String_Access;
57 Domain : String_Access;
60 Secure : Boolean := False;
63 type Key_Value is record
64 Key, Value : String_Access;
67 package Cookie_Table is new Table (Cookie_Data, Positive, 1, 5, 50);
68 -- This is the table to keep all cookies to be sent back to the server
70 package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50);
71 -- This is the table to keep all cookies received from the server
73 procedure Check_Environment;
74 pragma Inline (Check_Environment);
75 -- This procedure will raise Data_Error if Valid_Environment is False
78 -- Initialize CGI package by reading the runtime environment. This
79 -- procedure is called during elaboration. All exceptions raised during
80 -- this procedure are deferred.
82 -----------------------
83 -- Check_Environment --
84 -----------------------
86 procedure Check_Environment is
88 if not Valid_Environment then
91 end Check_Environment;
97 function Count return Natural is
99 return Key_Value_Table.Last;
106 function Exists (Key : String) return Boolean is
110 for K in 1 .. Key_Value_Table.Last loop
111 if Key_Value_Table.Table (K).Key.all = Key then
119 ----------------------
120 -- For_Every_Cookie --
121 ----------------------
123 procedure For_Every_Cookie is
129 for K in 1 .. Key_Value_Table.Last loop
132 Action (Key_Value_Table.Table (K).Key.all,
133 Key_Value_Table.Table (K).Value.all,
139 end For_Every_Cookie;
145 procedure Initialize is
147 HTTP_COOKIE : constant String := Metavariable (CGI.HTTP_Cookie);
149 procedure Set_Parameter_Table (Data : String);
150 -- Parse Data and insert information in Key_Value_Table
152 -------------------------
153 -- Set_Parameter_Table --
154 -------------------------
156 procedure Set_Parameter_Table (Data : String) is
158 procedure Add_Parameter (K : Positive; P : String);
159 -- Add a single parameter into the table at index K. The parameter
160 -- format is "key=value".
162 Count : constant Positive :=
163 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set (";"));
164 -- Count is the number of parameters in the string. Parameters are
165 -- separated by ampersand character.
167 Index : Positive := Data'First;
174 procedure Add_Parameter (K : Positive; P : String) is
175 Equal : constant Natural := Strings.Fixed.Index (P, "=");
180 Key_Value_Table.Table (K) :=
181 Key_Value'(new String'(Decode (P (P'First .. Equal - 1))),
182 new String'(Decode (P (Equal + 1 .. P'Last))));
186 -- Start of processing for Set_Parameter_Table
189 Key_Value_Table.Set_Last (Count);
191 for K in 1 .. Count - 1 loop
192 Sep := Strings.Fixed.Index (Data (Index .. Data'Last), ";");
194 Add_Parameter (K, Data (Index .. Sep - 1));
199 -- Add last parameter
201 Add_Parameter (Count, Data (Index .. Data'Last));
202 end Set_Parameter_Table;
204 -- Start of processing for Initialize
207 if HTTP_COOKIE /= "" then
208 Set_Parameter_Table (HTTP_COOKIE);
211 Valid_Environment := True;
215 Valid_Environment := False;
222 function Key (Position : Positive) return String is
226 if Position <= Key_Value_Table.Last then
227 return Key_Value_Table.Table (Position).Key.all;
229 raise Cookie_Not_Found;
237 function Ok return Boolean is
239 return Valid_Environment;
247 (Header : String := Default_Header;
248 Force : Boolean := False)
250 procedure Output_Cookies;
251 -- Iterate through the list of cookies to be sent to the server
258 procedure Output_Cookies is
260 procedure Output_One_Cookie
268 -- Output one cookie in the CGI header
270 -----------------------
271 -- Output_One_Cookie --
272 -----------------------
274 procedure Output_One_Cookie
284 Text_IO.Put ("Set-Cookie: ");
285 Text_IO.Put (Key & '=' & Value);
287 if Comment /= "" then
288 Text_IO.Put ("; Comment=" & Comment);
292 Text_IO.Put ("; Domain=" & Domain);
295 if Max_Age /= Natural'Last then
296 Text_IO.Put ("; Max-Age=");
297 Integer_Text_IO.Put (Max_Age, Width => 0);
301 Text_IO.Put ("; Path=" & Path);
305 Text_IO.Put ("; Secure");
309 end Output_One_Cookie;
311 -- Start of processing for Output_Cookies
314 for C in 1 .. Cookie_Table.Last loop
315 Output_One_Cookie (Cookie_Table.Table (C).Key.all,
316 Cookie_Table.Table (C).Value.all,
317 Cookie_Table.Table (C).Comment.all,
318 Cookie_Table.Table (C).Domain.all,
319 Cookie_Table.Table (C).Max_Age,
320 Cookie_Table.Table (C).Path.all,
321 Cookie_Table.Table (C).Secure);
325 -- Start of processing for Put_Header
328 if Header_Sent = False or else Force then
330 Text_IO.Put_Line (Header);
344 Comment : String := "";
345 Domain : String := "";
346 Max_Age : Natural := Natural'Last;
347 Path : String := "/";
348 Secure : Boolean := False)
351 Cookie_Table.Increment_Last;
353 Cookie_Table.Table (Cookie_Table.Last) :=
354 Cookie_Data'(new String'(Key),
356 new String'(Comment),
369 Required : Boolean := False) return String
374 for K in 1 .. Key_Value_Table.Last loop
375 if Key_Value_Table.Table (K).Key.all = Key then
376 return Key_Value_Table.Table (K).Value.all;
381 raise Cookie_Not_Found;
387 function Value (Position : Positive) return String is
391 if Position <= Key_Value_Table.Last then
392 return Key_Value_Table.Table (Position).Value.all;
394 raise Cookie_Not_Found;
398 -- Elaboration code for package
401 -- Initialize unit by reading the HTTP_COOKIE metavariable and fill
402 -- Key_Value_Table structure.