with Ada.Strings.Maps, Ada.Characters.Handling, Interfaces.C.Strings, Text_IO;
use  Ada.Strings.Maps, Ada.Characters.Handling, Interfaces.C.Strings, Text_IO;

package body CGI is
-- This package is an Ada 95 interface to the "Common Gateway Interface" (CGI).
-- This package makes it easier to create Ada programs that can be
-- invoked by HTTP servers using CGI.

-- Developed by David A. Wheeler, wheeler@ida.org, (C) June 1995-1999.
-- See the specification file for the license.

-- The following are key types and constants.

type Key_Value_Pair is record
   Key, Value : Unbounded_String;
   end record;

type Key_Value_Sequence is array(Positive range <>) of Key_Value_Pair;
type Access_Key_Value_Sequence is access Key_Value_Sequence;

Cookie_Data:  Access_Key_Value_Sequence;

Ampersands    : constant Character_Set      := To_Set('&');
Equals        : constant Character_Set      := To_Set('=');
Plus_To_Space : constant Character_Mapping  := To_Mapping("+", " ");
Semicolon     : constant Character_Set      := To_Set(';');


-- The following are data internal to this package.

Parsing_Errors_Occurred : Boolean := True;
Is_Index_Request_Made   : Boolean := False; -- Isindex request made?

CGI_Data : Access_Key_Value_Sequence; -- Initially nil.

Actual_CGI_Method : CGI_Method_Type := Get;


-- The following are private "Helper" subprograms.

function Value_Without_Exception(S : chars_ptr) return String is
-- Translate S from a C-style char* into an Ada String.
-- If S is Null_Ptr, return "", don't raise an exception.
begin
  if S = Null_Ptr then return "";
  else return Value(S);
  end if;
end Value_Without_Exception;
pragma Inline(Value_Without_Exception);


function Image(N : Natural) return String is
-- Convert Positive N to a string representation.  This is just like
-- Ada 'Image, but it doesn't put a space in front of it.
 Result : String := Natural'Image(N);
begin
 return Result( 2 .. Result'Length);
end Image;


function Field_End(Data: Unbounded_String; Field_Separator: Character;
               Starting_At : Positive := 1) return Natural is
-- Return the end-of-field position in Data after "Starting_Index",
-- assuming that fields are separated by the Field_Separator.
-- If there's no Field_Separator, return the end of the Data.
begin
  for I in Starting_At .. Length(Data) loop
    if Element(Data, I) = Field_Separator then return I-1; end if;
  end loop; 
  return Length(Data);
end Field_End;


function Hex_Value(H : in String) return Natural is
 -- Given hex string, return its Value as a Natural.
 Value : Natural := 0;
begin
 for P in 1.. H'Length loop
   Value := Value * 16;
   if H(P) in '0' .. '9' then Value := Value + Character'Pos(H(P)) -
                                               Character'Pos('0');
   elsif H(P) in 'A' .. 'F' then Value := Value + Character'Pos(H(P)) -
                                               Character'Pos('A') + 10;
   elsif H(P) in 'a' .. 'f' then Value := Value + Character'Pos(H(P)) -
                                               Character'Pos('a') + 10;
   else raise Constraint_Error;
   end if;
 end loop;
 return Value;
end Hex_Value;


procedure Decode(Data : in out Unbounded_String) is
 I : Positive := 1;
-- In the given string, convert pattern %HH into alphanumeric characters,
-- where HH is a hex number. Since this encoding only permits values
-- from %00 to %FF, there's no need to handle 16-bit characters.
begin
 while I <= Length(Data) - 2 loop
   if Element(Data, I) = '%' and Is_Hexadecimal_Digit(Element(Data, I+1)) and
      Is_Hexadecimal_Digit(Element(Data, I+2)) then
       Replace_Element(Data, I, Character'Val(Hex_Value(Slice(Data, I+1, I+2))));
       Delete(Data, I+1, I+2);
   end if;
   I := I + 1;
 end loop;
end Decode;




-- The following are public subprograms.


function Get_Environment(Variable : String) return String is
-- Return the value of the given environment variable.
-- If there's no such environment variable, return an empty string.

  function getenv(Variable : chars_ptr) return chars_ptr;
  pragma Import(C, getenv);
  -- getenv is a standard C library function; see K&R 2, 1988, page 253.
  -- it returns a pointer to the first character; do NOT free its results.

  Variable_In_C_Format : chars_ptr := New_String(Variable);
  Result_Ptr : chars_ptr := getenv(Variable_In_C_Format);
  Result : String := Value_Without_Exception(Result_Ptr);
begin
 Free(Variable_In_C_Format);
 return Result;
end Get_Environment;


function Parsing_Errors return Boolean is
begin
 return Parsing_Errors_Occurred;
end Parsing_Errors;


function Argument_Count return Natural is
begin
  if CGI_Data = null then return 0;
  else                   return CGI_Data.all'Length;
  end if;
end Argument_Count;


function Input_Received return Boolean is
  -- True if Input Received.
begin
  return Argument_Count /= 0; -- Input received if nonzero data entries.
end Input_Received;


function CGI_Method return CGI_Method_Type is
  -- Return Method used to send data.
begin
  return Actual_CGI_Method;
end CGI_Method;


function Is_Index return Boolean is
begin
  return Is_Index_Request_Made;
end Is_Index;


function Value(Key : in Unbounded_String; Index : in Positive := 1;
               Required : in Boolean := False)
         return Unbounded_String is
 My_Index : Positive := 1;
begin
 for I in 1 .. Argument_Count loop
   if CGI_Data.all(I).Key = Key then
      if Index = My_Index then
        return CGI_Data.all(I).Value;
      else
        My_Index := My_Index + 1;
      end if;
   end if;
 end loop;
 -- Didn't find the Key.
 if Required then
   raise Constraint_Error;
 else
   return To_Unbounded_String("");
 end if;
end Value;


function Value(Key : in String; Index : in Positive := 1;
               Required : in Boolean := False)
         return String is
begin
  return To_String(Value(To_Unbounded_String(Key), Index, Required));
end Value;


function Value(Key : in String; Index : in Positive := 1;
               Required : in Boolean := False)
         return Unbounded_String is
begin
  return Value(To_Unbounded_String(Key), Index, Required);
end Value;


function Value(Key : in Unbounded_String; Index : in Positive := 1;
               Required : in Boolean := False)
         return String is
begin
  return To_String(Value(Key, Index, Required));
end Value;


function Key_Exists(Key : in Unbounded_String; Index : in Positive := 1)
         return Boolean is
 My_Index : Positive := 1;
begin
 for I in 1 .. Argument_Count loop
   if CGI_Data.all(I).Key = Key then
      if Index = My_Index then
        return True;
      else
        My_Index := My_Index + 1;
      end if;
   end if;
 end loop;
 return False;
end Key_Exists;

function Key_Exists(Key : in String; Index : in Positive := 1) return Boolean is
begin
 return Key_Exists(To_Unbounded_String(Key), Index);
end Key_Exists;

function Key_Count(Key : in Unbounded_String) return Natural is
 Count : Natural := 0;
begin
 for I in 1 .. Argument_Count loop
   if CGI_Data.all(I).Key = Key then
        Count := Count + 1;
   end if;
 end loop;
 return Count;
end Key_Count;

function Key_Count(Key : in String) return Natural is
begin
  return Key_Count(To_Unbounded_String(Key));
end Key_Count;

function Key(Position : in Positive) return Unbounded_String is
begin
 return CGI_Data.all(Position).Key;
end Key;


function Key(Position : in Positive) return String is
begin
 return To_String(Key(Position));
end Key;


function Value(Position : in Positive) return Unbounded_String is
begin
 return CGI_Data.all(Position).Value;
end Value;


function Value(Position : in Positive) return String is
begin
 return To_String(Value(Position));
end Value;


function My_URL return String is
 -- Returns the URL of this script.
begin
  return "http://" & Get_Environment("SERVER_NAME") &
          Get_Environment("SCRIPT_NAME");
end My_URL;


procedure Put_CGI_Header(Header : in String := "Content-type: text/html") is
-- Put Header to Current_Output, followed by two carriage returns.
-- Default is to return a generated HTML document.
begin
  Put_Line(Header);
  New_Line;
end Put_CGI_Header;


procedure Put_HTML_Head(Title : in String; Mail_To : in String := "") is
begin
  Put_Line("<HTML><HEAD><TITLE>" & Title & "</TITLE>");
  if Mail_To /= "" then
    Put_Line("<LINK REV=""made"" HREF=""mailto:" &  Mail_To  & """>");
  end if;
  Put_Line("</HEAD><BODY>");
end Put_HTML_Head;


procedure Put_HTML_Heading(Title : in String; Level : in Positive) is
-- Put an HTML heading, such as <H1>Title</H1>
begin
  Put_Line("<H" & Image(Level) & ">" & Title & "</H" & Image(Level) & ">");
end Put_HTML_Heading;
 

procedure Put_HTML_Tail is
begin
  Put_Line("</BODY></HTML>");
end Put_HTML_Tail;


procedure Put_Error_Message(Message : in String) is
-- Put to Current_Output an error message.
begin
  Put_HTML_Head("Fatal Error Encountered by Script " & My_URL);
  Put_HTML_Heading("Fatal Error: " & Message, 1);
  Put_HTML_Tail;
  New_Line;
end Put_Error_Message;


procedure Put_Variables is
-- Put to Current_Output all of the data as an HTML-formatted String.
begin
 for I in 1 .. Argument_Count loop
   Put("<B>");
   Put(To_String(CGI_Data.all(I).Key));
   Put("</B> is <I>");
   Put(To_String(CGI_Data.all(I).Value));
   Put_Line("</I><BR>");
 end loop;
end Put_Variables;



-- Helper routine -
 
function Next_CRLF (S : in String; N : in Natural)
         return Natural
-- Return the location within the string of the next CRLF sequence
-- beginning with the Nth character within the string S;
-- return 0 if the next CRLF sequence is not in the string
is
   I : Natural := N;
begin
   while I < S'LAST loop
      if S(I) = ASCII.CR  and then  S(I+1) = ASCII.LF then
         return I;
      else
         I := I + 1;
      end if;
   end loop;
   return 0;
end;
 
 
 
function Line_Count (Value : in String) return Natural
-- Count the number of lines inside the given string.
-- returns 0 if Key_Value is the empty/null string,
-- i.e., if its length is zero; otherwise, returns
-- the number of "lines" in Key_Value, effectively
-- returning the number of CRLF sequences + 1;
-- for example, both "AB/CDEF//GHI" and "AB/CDEF//"
-- (where / is CRLF) return Line_Count of 4.
is
   Number_of_Lines : Natural := 0;
   I : Natural := Value'FIRST;
begin
   if Value'LENGTH = 0 then
      return 0;
   else
      loop
         I := Next_CRLF (Value, I+1);
      exit when I = 0;
         Number_of_Lines := Number_of_Lines + 1;
      end loop;
      -- Always count the line (either non-null or null) after
      -- the last CRLF as a line
      Number_of_Lines := Number_of_Lines + 1;
      return Number_of_Lines;
   end if;
end;
 

function Line (Value : in String; Position : in Positive)
               return String
-- Return the given line position value.
-- that is separated by the n-1 and the nth CRLF sequence
-- or if there is no nth CRLF sequence, then returns the line
-- delimited by the n-1 CRLF and the end of the string
 
is
   Next : Natural := 1;
   Line_Number : Natural := 0;
   Start_of_Line, End_of_Line : Natural;
begin
   End_of_Line := Next_CRLF (Value, 1);
   if End_of_Line = 0 then
      -- no CRLF sequence on the "line"
      if Position > 1 then
         -- raise an exception if requesting > 1
         raise Constraint_Error;
      else
         -- otherwise, requesting first line
         -- return original string, even if null string
         return Value;
      end if;
   else
      -- There's at least one CRLF on the "line"
      for I in 1..Position loop
         Start_of_Line := Next;
         End_of_Line := Next_CRLF (Value, Next);
         -- normally, the line is Start_of_Line .. End_of_Line-1
         -- if no more CRLFs on line, it's Start_of_Line .. 'LAST
         exit when End_of_Line = 0;
         Line_Number := Line_Number + 1;
         -- skip past the 2 chars, CRLF, to start next search
         Next := End_of_Line + 2;
      end loop;
      -- if we fall out of loop normally, End_of_Line is non-zero
      if End_of_Line > 0 then
         -- and Position had better be equal to Line_Number
         if Position = Line_Number then
            return Value (Start_of_Line .. End_of_Line-1);
         else
            raise Constraint_Error;
         end if;
      else
         -- we exit the loop prematurely because there's not
         -- enough CRLFs in the line,
         -- thus Line_Number is one less than Position
         if Position = Line_Number+1 then
            return Value (Start_of_Line .. Value'LAST);
         else
            raise Constraint_Error;
         end if;
      end if;
 end if;
end Line;
 

function Line_Count_of_Value (Key : String) return Natural is
begin
   if Key_Exists (Key) then
      return Line_Count (Value(Key));
   else
      return 0;
   end if;
end Line_Count_of_Value;


function Value_of_Line (Key : String; Position : Positive) return String is
begin
   if Key_Exists (Key) then
      return Line (Value(Key), Position);
   else
      return "";
   end if;
end Value_of_Line;



-- Initialization routines, including some private procedures only
-- used during initialization.

procedure Set_CGI_Position(Key_Number : in Positive;
                           Datum : in Unbounded_String) is
  Last : Natural := Field_End(Datum, '=');
-- Given a Key number and a datum of the form key=value
-- assign the CGI_Data(Key_Number) the values of key and value.
begin
  CGI_Data.all(Key_Number).Key   := To_Unbounded_String(Slice(Datum, 1, Last));
  CGI_Data.all(Key_Number).Value := To_Unbounded_String(Slice(Datum,
                                                      Last+2, Length(Datum)));
  Decode(CGI_Data.all(Key_Number).Key);
  Decode(CGI_Data.all(Key_Number).Value);
end Set_CGI_Position;


procedure Set_CGI_Data(Raw_Data : in Unbounded_String) is
-- Set CGI_Data using Raw_Data.
  Key_Number : Positive := 1;
  Character_Position : Positive := 1;
  Last : Natural;
begin
 while Character_Position <= Length(Raw_Data) loop
   Last := Field_End(Raw_Data, '&', Character_Position);
   Set_CGI_Position(Key_Number, To_Unbounded_String(
                       Slice(Raw_Data, Character_Position, Last)));
   Character_Position := Last + 2; -- Skip over field separator.
   Key_Number := Key_Number + 1;
 end loop;
end Set_CGI_Data;


procedure Set_Cookie_Position(Key_Number : in Positive;
                              Datum : in Unbounded_String) is
  Last : Natural := Field_End(Datum, '=');
  -- Parse through the cookie raw data and put in the cookie data array
  -- Given a Key number and a datum of the form key=value
  -- assign the Cookie_Data(Key_Number) the values of key and value.
begin
    Cookie_Data.all(Key_Number).Key :=
       To_Unbounded_String(Slice(Datum, 1, Last));
    Cookie_Data.all(Key_Number).Value :=
       To_Unbounded_String(Slice(Datum, Last+2, Length(Datum)));
    Decode(Cookie_Data.all(Key_Number).Key);
    Decode(Cookie_Data.all(Key_Number).Value);
end Set_Cookie_Position;



procedure Set_Cookie_Data(Raw_Data : in Unbounded_String) is
  Key_Number : Positive := 1;
  Character_Position : Positive := 1;
  Last : Natural;
  -- Parse through the cookie raw data and put in the cookie data array
begin
  while Character_Position <= Length(Raw_Data) loop
    Last := Field_End(Raw_Data, ';', Character_Position);
    Set_Cookie_Position(Key_Number,
      To_Unbounded_String(Slice(Raw_Data, Character_Position, Last)));
    Character_Position := Last + 2; -- Skip over field separator.
    Key_Number := Key_Number + 1;
  end loop;
end Set_Cookie_Data;


function Cookie_Value(Key : in Unbounded_String; Index : in Positive := 1;
                      Required : in Boolean := False)
  return Unbounded_String is
  My_Index : Positive := 1;
  -- Read the cookie from the browser request,
  -- returns the data or a null pointer if no cookie data
begin
  for I in 1 .. Cookie_Data'Last loop
    if Cookie_Data.all(I).Key = Key then
      if Index = My_Index then
        return Cookie_Data.all(I).Value;
      else
        My_Index := My_Index + 1;
      end if;
    end if;
  end loop;
  -- Didn't find the Key.
  if Required then
    raise Constraint_Error;
  else
    return To_Unbounded_String("");
  end if;
end Cookie_Value;



function Cookie_Value(Key : in String; Index : in Positive := 1;
                      Required : in Boolean := False) return String is
begin
  return To_String(Cookie_Value(To_Unbounded_String(Key), Index, Required));
end Cookie_Value;


function Cookie_Value(Key : in String; Index : in Positive := 1;
                      Required : in Boolean := False)
  return Unbounded_String is
begin
  return Cookie_Value(To_Unbounded_String(Key), Index, Required);
end Cookie_Value;


function Cookie_Value(Key : in Unbounded_String; Index : in Positive := 1;
                      Required : in Boolean := False) return String is
begin
  return To_String(Value(Key, Index, Required));
end Cookie_Value;

function Cookie_Value(Position : in Positive) return Unbounded_String is
begin
  return Cookie_Data.all(Position).Value;
end Cookie_Value;


function Cookie_Value(Position : in Positive) return String is
begin
  return To_String(Value(Position));
end Cookie_Value;


procedure Read_Cookie is
  Temp_Ptr : Access_Key_Value_Sequence;
  Raw_Data: Unbounded_String;
  Temp_Number: Natural;
begin -- read_cookie
  Raw_Data := To_Unbounded_String(Get_Environment("HTTP_COOKIE"));
  if Raw_Data /= "" then
    Temp_Number:=Ada.Strings.Unbounded.Count(Raw_Data, Semicolon)+1;
    Cookie_Data := new Key_Value_Sequence(1 .. temp_number);
    Set_Cookie_Data(Raw_Data);
  else
    Cookie_Data:=new Key_Value_Sequence(1..1);
  end if;
end Read_Cookie;


procedure Set_Cookie(Key   : String;
                     Value : String; 
                     Expires : String := ""; 
                     Path  : String := Get_Environment("PATH_INFO"); 
                     Domain: String := Get_Environment("SERVER_NAME");
                     Secure: Boolean := False ) is
  -- Sends a cookie to the browser.
  -- Do this before sending the header for the HTML.
begin
  Put("Set-Cookie: ");
  Put(Key & "=" & Value & ";");
  if Expires /= "" then
    Put("expires=" & Expires & ";");
  end if;
  if Path /= "" then
    Put("path=" & Path  & ";");
  end if;
  if Domain /= "" then
    Put("domain=" & Domain & ";");
  end if;
  if Secure then 
    put_line("secure");
  else
    new_line;
  end if;
end Set_Cookie;


procedure Initialize is
  Raw_Data : Unbounded_String;  -- Initially an empty string (LRM A.4.5(73))
  Request_Method_Text : String := To_Upper(Get_Environment("REQUEST_METHOD"));
  -- Initialize this package, most importantly the CGI_Data variable.
begin
 if Request_Method_Text = "GET" then
    Actual_CGI_Method := Get;
    Raw_Data := To_Unbounded_String(Get_Environment("QUERY_STRING"));
 elsif Request_Method_Text = "POST" then
    Actual_CGI_Method := Post;
    declare
      Raw_Data_String : String(1 ..
                         Integer'Value(Get_Environment("CONTENT_LENGTH")));
    begin
      Get(Raw_Data_String);
      Raw_Data := To_Unbounded_String(Raw_Data_String);
    end;
 else
    Actual_CGI_Method := Unknown;
 end if;

 Translate(Raw_Data, Mapping => Plus_To_Space); -- Convert "+"s to spaces.

 if Length(Raw_Data) > 0 then
   if Index(Raw_Data, Equals) = 0 then
     -- No "=" found, so this is an "Isindex" request.
     Is_Index_Request_Made := True;
     Raw_Data := "isindex=" & Raw_Data;
   end if;
   CGI_Data := new Key_Value_Sequence(1 .. 
                   Ada.Strings.Unbounded.Count(Raw_Data, Ampersands)+1);
   Set_CGI_Data(Raw_Data); 
   Parsing_Errors_Occurred := False;
 end if;

end Initialize;

-- This library automatically parses CGI and cookie input on program start.
-- This is a trade-off, limiting flexibility very slightly
-- (in the weird case where you don't want this auto-initialization)
-- but it eliminates a common error (forgetting to initialize things).
-- If you really don't want auto-initialization, just remove the calls
-- here and make the calls visible in the spec.  Don't forget to call them!

begin
  Initialize;
  Read_Cookie;
end CGI;