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-2019, 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-- 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.               --
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
32with Ada.Strings.Fixed;
33with Ada.Strings.Maps;
34with Ada.Text_IO;
35with Ada.Integer_Text_IO;
36
37with GNAT.Table;
38
39package 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
400begin
401   --  Initialize unit by reading the HTTP_COOKIE metavariable and fill
402   --  Key_Value_Table structure.
403
404   Initialize;
405end GNAT.CGI.Cookie;
406