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-2005, 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 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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 has 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       --  Start of processing for Set_Parameter_Table
 189
 190       begin
 191          Key_Value_Table.Set_Last (Count);
 192
 193          for K in 1 .. Count - 1 loop
 194             Sep := Strings.Fixed.Index (Data (Index .. Data'Last), ";");
 195
 196             Add_Parameter (K, Data (Index .. Sep - 1));
 197
 198             Index := Sep + 2;
 199          end loop;
 200
 201          --  Add last parameter
 202
 203          Add_Parameter (Count, Data (Index .. Data'Last));
 204       end Set_Parameter_Table;
 205
 206    --  Start of processing for Initialize
 207
 208    begin
 209       if HTTP_COOKIE /= "" then
 210          Set_Parameter_Table (HTTP_COOKIE);
 211       end if;
 212
 213       Valid_Environment := True;
 214
 215    exception
 216       when others =>
 217          Valid_Environment := False;
 218    end Initialize;
 219
 220    ---------
 221    -- Key --
 222    ---------
 223
 224    function Key (Position : Positive) return String is
 225    begin
 226       Check_Environment;
 227
 228       if Position <= Key_Value_Table.Last then
 229          return Key_Value_Table.Table (Position).Key.all;
 230       else
 231          raise Cookie_Not_Found;
 232       end if;
 233    end Key;
 234
 235    --------
 236    -- Ok --
 237    --------
 238
 239    function Ok return Boolean is
 240    begin
 241       return Valid_Environment;
 242    end Ok;
 243
 244    ----------------
 245    -- Put_Header --
 246    ----------------
 247
 248    procedure Put_Header
 249      (Header : String  := Default_Header;
 250       Force  : Boolean := False)
 251    is
 252       procedure Output_Cookies;
 253       --  Iterate through the list of cookies to be sent to the server
 254       --  and output them.
 255
 256       --------------------
 257       -- Output_Cookies --
 258       --------------------
 259
 260       procedure Output_Cookies is
 261
 262          procedure Output_One_Cookie
 263            (Key     : String;
 264             Value   : String;
 265             Comment : String;
 266             Domain  : String;
 267             Max_Age : Natural;
 268             Path    : String;
 269             Secure  : Boolean);
 270          --  Output one cookie in the CGI header
 271
 272          -----------------------
 273          -- Output_One_Cookie --
 274          -----------------------
 275
 276          procedure Output_One_Cookie
 277            (Key     : String;
 278             Value   : String;
 279             Comment : String;
 280             Domain  : String;
 281             Max_Age : Natural;
 282             Path    : String;
 283             Secure  : Boolean)
 284          is
 285          begin
 286             Text_IO.Put ("Set-Cookie: ");
 287             Text_IO.Put (Key & '=' & Value);
 288
 289             if Comment /= "" then
 290                Text_IO.Put ("; Comment=" & Comment);
 291             end if;
 292
 293             if Domain /= "" then
 294                Text_IO.Put ("; Domain=" & Domain);
 295             end if;
 296
 297             if Max_Age /= Natural'Last then
 298                Text_IO.Put ("; Max-Age=");
 299                Integer_Text_IO.Put (Max_Age, Width => 0);
 300             end if;
 301
 302             if Path /= "" then
 303                Text_IO.Put ("; Path=" & Path);
 304             end if;
 305
 306             if Secure then
 307                Text_IO.Put ("; Secure");
 308             end if;
 309
 310             Text_IO.New_Line;
 311          end Output_One_Cookie;
 312
 313       --  Start of processing for Output_Cookies
 314
 315       begin
 316          for C in 1 .. Cookie_Table.Last loop
 317             Output_One_Cookie (Cookie_Table.Table (C).Key.all,
 318                                Cookie_Table.Table (C).Value.all,
 319                                Cookie_Table.Table (C).Comment.all,
 320                                Cookie_Table.Table (C).Domain.all,
 321                                Cookie_Table.Table (C).Max_Age,
 322                                Cookie_Table.Table (C).Path.all,
 323                                Cookie_Table.Table (C).Secure);
 324          end loop;
 325       end Output_Cookies;
 326
 327    --  Start of processing for Put_Header
 328
 329    begin
 330       if Header_Sent = False or else Force then
 331          Check_Environment;
 332          Text_IO.Put_Line (Header);
 333          Output_Cookies;
 334          Text_IO.New_Line;
 335          Header_Sent := True;
 336       end if;
 337    end Put_Header;
 338
 339    ---------
 340    -- Set --
 341    ---------
 342
 343    procedure Set
 344      (Key     : String;
 345       Value   : String;
 346       Comment : String   := "";
 347       Domain  : String   := "";
 348       Max_Age : Natural  := Natural'Last;
 349       Path    : String   := "/";
 350       Secure  : Boolean  := False)
 351    is
 352    begin
 353       Cookie_Table.Increment_Last;
 354
 355       Cookie_Table.Table (Cookie_Table.Last) :=
 356         Cookie_Data'(new String'(Key),
 357                      new String'(Value),
 358                      new String'(Comment),
 359                      new String'(Domain),
 360                      Max_Age,
 361                      new String'(Path),
 362                      Secure);
 363    end Set;
 364
 365    -----------
 366    -- Value --
 367    -----------
 368
 369    function Value
 370      (Key      : String;
 371       Required : Boolean := False) return String
 372    is
 373    begin
 374       Check_Environment;
 375
 376       for K in 1 .. Key_Value_Table.Last loop
 377          if Key_Value_Table.Table (K).Key.all = Key then
 378             return Key_Value_Table.Table (K).Value.all;
 379          end if;
 380       end loop;
 381
 382       if Required then
 383          raise Cookie_Not_Found;
 384       else
 385          return "";
 386       end if;
 387    end Value;
 388
 389    function Value (Position : Positive) return String is
 390    begin
 391       Check_Environment;
 392
 393       if Position <= Key_Value_Table.Last then
 394          return Key_Value_Table.Table (Position).Value.all;
 395       else
 396          raise Cookie_Not_Found;
 397       end if;
 398    end Value;
 399
 400 --  Elaboration code for package
 401
 402 begin
 403    --  Initialize unit by reading the HTTP_COOKIE metavariable and fill
 404    --  Key_Value_Table structure.
 405
 406    Initialize;
 407 end GNAT.CGI.Cookie;