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-- 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