gcc/ada/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-2003 Ada Core Technologies, Inc.           --
  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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Strings.Fixed;
  35 with Ada.Strings.Maps;
  36 with Ada.Text_IO;
  37 with Ada.Integer_Text_IO;
  38
  39 with GNAT.Table;
  40
  41 package body GNAT.CGI.Cookie is
  42
  43    use Ada;
  44
  45    Valid_Environment : Boolean := False;
  46    --  This boolean will be set to True if the initialization was fine.
  47
  48    Header_Sent : Boolean := False;
  49    --  Will be set to True when the header will be sent.
  50
  51    --  Cookie data that have been added.
  52
  53    type String_Access is access String;
  54
  55    type Cookie_Data is record
  56       Key     : String_Access;
  57       Value   : String_Access;
  58       Comment : String_Access;
  59       Domain  : String_Access;
  60       Max_Age : Natural;
  61       Path    : String_Access;
  62       Secure  : Boolean := False;
  63    end record;
  64
  65    type Key_Value is record
  66       Key, Value : String_Access;
  67    end record;
  68
  69    package Cookie_Table is new Table (Cookie_Data, Positive, 1, 5, 50);
  70    --  This is the table to keep all cookies to be sent back to the server.
  71
  72    package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50);
  73    --  This is the table to keep all cookies received from the server.
  74
  75    procedure Check_Environment;
  76    pragma Inline (Check_Environment);
  77    --  This procedure will raise Data_Error if Valid_Environment is False.
  78
  79    procedure Initialize;
  80    --  Initialize CGI package by reading the runtime environment. This
  81    --  procedure is called during elaboration. All exceptions raised during
  82    --  this procedure are deferred.
  83
  84    -----------------------
  85    -- Check_Environment --
  86    -----------------------
  87
  88    procedure Check_Environment is
  89    begin
  90       if not Valid_Environment then
  91          raise Data_Error;
  92       end if;
  93    end Check_Environment;
  94
  95    -----------
  96    -- Count --
  97    -----------
  98
  99    function Count return Natural is
 100    begin
 101       return Key_Value_Table.Last;
 102    end Count;
 103
 104    ------------
 105    -- Exists --
 106    ------------
 107
 108    function Exists (Key : String) return Boolean is
 109    begin
 110       Check_Environment;
 111
 112       for K in 1 .. Key_Value_Table.Last loop
 113          if Key_Value_Table.Table (K).Key.all = Key then
 114             return True;
 115          end if;
 116       end loop;
 117
 118       return False;
 119    end Exists;
 120
 121    ----------------------
 122    -- For_Every_Cookie --
 123    ----------------------
 124
 125    procedure For_Every_Cookie is
 126       Quit : Boolean;
 127
 128    begin
 129       Check_Environment;
 130
 131       for K in 1 .. Key_Value_Table.Last loop
 132          Quit := False;
 133
 134          Action (Key_Value_Table.Table (K).Key.all,
 135                  Key_Value_Table.Table (K).Value.all,
 136                  K,
 137                  Quit);
 138
 139          exit when Quit;
 140       end loop;
 141    end For_Every_Cookie;
 142
 143    ----------------
 144    -- Initialize --
 145    ----------------
 146
 147    procedure Initialize is
 148
 149       HTTP_COOKIE : constant String := Metavariable (CGI.HTTP_Cookie);
 150
 151       procedure Set_Parameter_Table (Data : String);
 152       --  Parse Data and insert information in Key_Value_Table.
 153
 154       -------------------------
 155       -- Set_Parameter_Table --
 156       -------------------------
 157
 158       procedure Set_Parameter_Table (Data : String) is
 159
 160          procedure Add_Parameter (K : Positive; P : String);
 161          --  Add a single parameter into the table at index K. The parameter
 162          --  format is "key=value".
 163
 164          Count : constant Positive
 165            := 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set (";"));
 166          --  Count is the number of parameters in the string. Parameters are
 167          --  separated by ampersand character.
 168
 169          Index : Positive := Data'First;
 170          Sep   : Natural;
 171
 172          -------------------
 173          -- Add_Parameter --
 174          -------------------
 175
 176          procedure Add_Parameter (K : Positive; P : String) is
 177             Equal : constant Natural := Strings.Fixed.Index (P, "=");
 178          begin
 179             if Equal = 0 then
 180                raise Data_Error;
 181             else
 182                Key_Value_Table.Table (K) :=
 183                  Key_Value'(new String'(Decode (P (P'First .. Equal - 1))),
 184                             new String'(Decode (P (Equal + 1 .. P'Last))));
 185             end if;
 186          end Add_Parameter;
 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    begin
 205       if HTTP_COOKIE /= "" then
 206          Set_Parameter_Table (HTTP_COOKIE);
 207       end if;
 208
 209       Valid_Environment := True;
 210
 211    exception
 212       when others =>
 213          Valid_Environment := False;
 214    end Initialize;
 215
 216    ---------
 217    -- Key --
 218    ---------
 219
 220    function Key (Position : Positive) return String is
 221    begin
 222       Check_Environment;
 223
 224       if Position <= Key_Value_Table.Last then
 225          return Key_Value_Table.Table (Position).Key.all;
 226       else
 227          raise Cookie_Not_Found;
 228       end if;
 229    end Key;
 230
 231    --------
 232    -- Ok --
 233    --------
 234
 235    function Ok return Boolean is
 236    begin
 237       return Valid_Environment;
 238    end Ok;
 239
 240    ----------------
 241    -- Put_Header --
 242    ----------------
 243
 244    procedure Put_Header
 245      (Header : String  := Default_Header;
 246       Force  : Boolean := False)
 247    is
 248
 249       procedure Output_Cookies;
 250       --  Iterate through the list of cookies to be sent to the server
 251       --  and output them.
 252
 253       --------------------
 254       -- Output_Cookies --
 255       --------------------
 256
 257       procedure Output_Cookies is
 258
 259          procedure Output_One_Cookie
 260            (Key     : String;
 261             Value   : String;
 262             Comment : String;
 263             Domain  : String;
 264             Max_Age : Natural;
 265             Path    : String;
 266             Secure  : Boolean);
 267          --  Output one cookie in the CGI header.
 268
 269          -----------------------
 270          -- Output_One_Cookie --
 271          -----------------------
 272
 273          procedure Output_One_Cookie
 274            (Key     : String;
 275             Value   : String;
 276             Comment : String;
 277             Domain  : String;
 278             Max_Age : Natural;
 279             Path    : String;
 280             Secure  : Boolean)
 281          is
 282          begin
 283             Text_IO.Put ("Set-Cookie: ");
 284             Text_IO.Put (Key & '=' & Value);
 285
 286             if Comment /= "" then
 287                Text_IO.Put ("; Comment=" & Comment);
 288             end if;
 289
 290             if Domain /= "" then
 291                Text_IO.Put ("; Domain=" & Domain);
 292             end if;
 293
 294             if Max_Age /= Natural'Last then
 295                Text_IO.Put ("; Max-Age=");
 296                Integer_Text_IO.Put (Max_Age, Width => 0);
 297             end if;
 298
 299             if Path /= "" then
 300                Text_IO.Put ("; Path=" & Path);
 301             end if;
 302
 303             if Secure then
 304                Text_IO.Put ("; Secure");
 305             end if;
 306
 307             Text_IO.New_Line;
 308          end Output_One_Cookie;
 309
 310       --  Start of processing for Output_Cookies
 311
 312       begin
 313          for C in 1 .. Cookie_Table.Last loop
 314             Output_One_Cookie (Cookie_Table.Table (C).Key.all,
 315                                Cookie_Table.Table (C).Value.all,
 316                                Cookie_Table.Table (C).Comment.all,
 317                                Cookie_Table.Table (C).Domain.all,
 318                                Cookie_Table.Table (C).Max_Age,
 319                                Cookie_Table.Table (C).Path.all,
 320                                Cookie_Table.Table (C).Secure);
 321          end loop;
 322       end Output_Cookies;
 323
 324    --  Start of processing for Put_Header
 325
 326    begin
 327       if Header_Sent = False or else Force then
 328          Check_Environment;
 329          Text_IO.Put_Line (Header);
 330          Output_Cookies;
 331          Text_IO.New_Line;
 332          Header_Sent := True;
 333       end if;
 334    end Put_Header;
 335
 336    ---------
 337    -- Set --
 338    ---------
 339
 340    procedure Set
 341      (Key     : String;
 342       Value   : String;
 343       Comment : String   := "";
 344       Domain  : String   := "";
 345       Max_Age : Natural  := Natural'Last;
 346       Path    : String   := "/";
 347       Secure  : Boolean  := False) is
 348    begin
 349       Cookie_Table.Increment_Last;
 350
 351       Cookie_Table.Table (Cookie_Table.Last) :=
 352         Cookie_Data'(new String'(Key),
 353                      new String'(Value),
 354                      new String'(Comment),
 355                      new String'(Domain),
 356                      Max_Age,
 357                      new String'(Path),
 358                      Secure);
 359    end Set;
 360
 361    -----------
 362    -- Value --
 363    -----------
 364
 365    function Value
 366      (Key      : String;
 367       Required : Boolean := False)
 368       return     String
 369    is
 370    begin
 371       Check_Environment;
 372
 373       for K in 1 .. Key_Value_Table.Last loop
 374          if Key_Value_Table.Table (K).Key.all = Key then
 375             return Key_Value_Table.Table (K).Value.all;
 376          end if;
 377       end loop;
 378
 379       if Required then
 380          raise Cookie_Not_Found;
 381       else
 382          return "";
 383       end if;
 384    end Value;
 385
 386    function Value (Position : Positive) return String is
 387    begin
 388       Check_Environment;
 389
 390       if Position <= Key_Value_Table.Last then
 391          return Key_Value_Table.Table (Position).Value.all;
 392       else
 393          raise Cookie_Not_Found;
 394       end if;
 395    end Value;
 396
 397 --  Elaboration code for package
 398
 399 begin
 400    --  Initialize unit by reading the HTTP_COOKIE metavariable and fill
 401    --  Key_Value_Table structure.
 402
 403    Initialize;
 404 end GNAT.CGI.Cookie;