File : g-cgicoo.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T . C G I . C O O K I E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2000-2010, AdaCore --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with Ada.Strings.Fixed;
33 with Ada.Strings.Maps;
34 with Ada.Text_IO;
35 with Ada.Integer_Text_IO;
36
37 with GNAT.Table;
38
39 package body GNAT.CGI.Cookie is
40
41 use Ada;
42
43 Valid_Environment : Boolean := False;
44 -- This boolean will be set to True if the initialization was fine
45
46 Header_Sent : Boolean := False;
47 -- Will be set to True when the header will be sent
48
49 -- Cookie data that has been added
50
51 type String_Access is access String;
52
53 type Cookie_Data is record
54 Key : String_Access;
55 Value : String_Access;
56 Comment : String_Access;
57 Domain : String_Access;
58 Max_Age : Natural;
59 Path : String_Access;
60 Secure : Boolean := False;
61 end record;
62
63 type Key_Value is record
64 Key, Value : String_Access;
65 end record;
66
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
69
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
72
73 procedure Check_Environment;
74 pragma Inline (Check_Environment);
75 -- This procedure will raise Data_Error if Valid_Environment is False
76
77 procedure Initialize;
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.
81
82 -----------------------
83 -- Check_Environment --
84 -----------------------
85
86 procedure Check_Environment is
87 begin
88 if not Valid_Environment then
89 raise Data_Error;
90 end if;
91 end Check_Environment;
92
93 -----------
94 -- Count --
95 -----------
96
97 function Count return Natural is
98 begin
99 return Key_Value_Table.Last;
100 end Count;
101
102 ------------
103 -- Exists --
104 ------------
105
106 function Exists (Key : String) return Boolean is
107 begin
108 Check_Environment;
109
110 for K in 1 .. Key_Value_Table.Last loop
111 if Key_Value_Table.Table (K).Key.all = Key then
112 return True;
113 end if;
114 end loop;
115
116 return False;
117 end Exists;
118
119 ----------------------
120 -- For_Every_Cookie --
121 ----------------------
122
123 procedure For_Every_Cookie is
124 Quit : Boolean;
125
126 begin
127 Check_Environment;
128
129 for K in 1 .. Key_Value_Table.Last loop
130 Quit := False;
131
132 Action (Key_Value_Table.Table (K).Key.all,
133 Key_Value_Table.Table (K).Value.all,
134 K,
135 Quit);
136
137 exit when Quit;
138 end loop;
139 end For_Every_Cookie;
140
141 ----------------
142 -- Initialize --
143 ----------------
144
145 procedure Initialize is
146
147 HTTP_COOKIE : constant String := Metavariable (CGI.HTTP_Cookie);
148
149 procedure Set_Parameter_Table (Data : String);
150 -- Parse Data and insert information in Key_Value_Table
151
152 -------------------------
153 -- Set_Parameter_Table --
154 -------------------------
155
156 procedure Set_Parameter_Table (Data : String) is
157
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".
161
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.
166
167 Index : Positive := Data'First;
168 Sep : Natural;
169
170 -------------------
171 -- Add_Parameter --
172 -------------------
173
174 procedure Add_Parameter (K : Positive; P : String) is
175 Equal : constant Natural := Strings.Fixed.Index (P, "=");
176 begin
177 if Equal = 0 then
178 raise Data_Error;
179 else
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))));
183 end if;
184 end Add_Parameter;
185
186 -- Start of processing for Set_Parameter_Table
187
188 begin
189 Key_Value_Table.Set_Last (Count);
190
191 for K in 1 .. Count - 1 loop
192 Sep := Strings.Fixed.Index (Data (Index .. Data'Last), ";");
193
194 Add_Parameter (K, Data (Index .. Sep - 1));
195
196 Index := Sep + 2;
197 end loop;
198
199 -- Add last parameter
200
201 Add_Parameter (Count, Data (Index .. Data'Last));
202 end Set_Parameter_Table;
203
204 -- Start of processing for Initialize
205
206 begin
207 if HTTP_COOKIE /= "" then
208 Set_Parameter_Table (HTTP_COOKIE);
209 end if;
210
211 Valid_Environment := True;
212
213 exception
214 when others =>
215 Valid_Environment := False;
216 end Initialize;
217
218 ---------
219 -- Key --
220 ---------
221
222 function Key (Position : Positive) return String is
223 begin
224 Check_Environment;
225
226 if Position <= Key_Value_Table.Last then
227 return Key_Value_Table.Table (Position).Key.all;
228 else
229 raise Cookie_Not_Found;
230 end if;
231 end Key;
232
233 --------
234 -- Ok --
235 --------
236
237 function Ok return Boolean is
238 begin
239 return Valid_Environment;
240 end Ok;
241
242 ----------------
243 -- Put_Header --
244 ----------------
245
246 procedure Put_Header
247 (Header : String := Default_Header;
248 Force : Boolean := False)
249 is
250 procedure Output_Cookies;
251 -- Iterate through the list of cookies to be sent to the server
252 -- and output them.
253
254 --------------------
255 -- Output_Cookies --
256 --------------------
257
258 procedure Output_Cookies is
259
260 procedure Output_One_Cookie
261 (Key : String;
262 Value : String;
263 Comment : String;
264 Domain : String;
265 Max_Age : Natural;
266 Path : String;
267 Secure : Boolean);
268 -- Output one cookie in the CGI header
269
270 -----------------------
271 -- Output_One_Cookie --
272 -----------------------
273
274 procedure Output_One_Cookie
275 (Key : String;
276 Value : String;
277 Comment : String;
278 Domain : String;
279 Max_Age : Natural;
280 Path : String;
281 Secure : Boolean)
282 is
283 begin
284 Text_IO.Put ("Set-Cookie: ");
285 Text_IO.Put (Key & '=' & Value);
286
287 if Comment /= "" then
288 Text_IO.Put ("; Comment=" & Comment);
289 end if;
290
291 if Domain /= "" then
292 Text_IO.Put ("; Domain=" & Domain);
293 end if;
294
295 if Max_Age /= Natural'Last then
296 Text_IO.Put ("; Max-Age=");
297 Integer_Text_IO.Put (Max_Age, Width => 0);
298 end if;
299
300 if Path /= "" then
301 Text_IO.Put ("; Path=" & Path);
302 end if;
303
304 if Secure then
305 Text_IO.Put ("; Secure");
306 end if;
307
308 Text_IO.New_Line;
309 end Output_One_Cookie;
310
311 -- Start of processing for Output_Cookies
312
313 begin
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);
322 end loop;
323 end Output_Cookies;
324
325 -- Start of processing for Put_Header
326
327 begin
328 if Header_Sent = False or else Force then
329 Check_Environment;
330 Text_IO.Put_Line (Header);
331 Output_Cookies;
332 Text_IO.New_Line;
333 Header_Sent := True;
334 end if;
335 end Put_Header;
336
337 ---------
338 -- Set --
339 ---------
340
341 procedure Set
342 (Key : String;
343 Value : String;
344 Comment : String := "";
345 Domain : String := "";
346 Max_Age : Natural := Natural'Last;
347 Path : String := "/";
348 Secure : Boolean := False)
349 is
350 begin
351 Cookie_Table.Increment_Last;
352
353 Cookie_Table.Table (Cookie_Table.Last) :=
354 Cookie_Data'(new String'(Key),
355 new String'(Value),
356 new String'(Comment),
357 new String'(Domain),
358 Max_Age,
359 new String'(Path),
360 Secure);
361 end Set;
362
363 -----------
364 -- Value --
365 -----------
366
367 function Value
368 (Key : String;
369 Required : Boolean := False) return String
370 is
371 begin
372 Check_Environment;
373
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;
377 end if;
378 end loop;
379
380 if Required then
381 raise Cookie_Not_Found;
382 else
383 return "";
384 end if;
385 end Value;
386
387 function Value (Position : Positive) return String is
388 begin
389 Check_Environment;
390
391 if Position <= Key_Value_Table.Last then
392 return Key_Value_Table.Table (Position).Value.all;
393 else
394 raise Cookie_Not_Found;
395 end if;
396 end Value;
397
398 -- Elaboration code for package
399
400 begin
401 -- Initialize unit by reading the HTTP_COOKIE metavariable and fill
402 -- Key_Value_Table structure.
403
404 Initialize;
405 end GNAT.CGI.Cookie;