File : adagio-http-header.adb
------------------------------------------------------------------------------
-- ADAGIO - ADALID - AENEA. --
-- --
-- Copyright (C) 2003 --
-- A. Mosteo. --
-- --
-- Authors: A. Mosteo. (adagio@mosteo.com) --
-- --
-- If you have any questions in regard to this software, please address --
-- them to the above email. --
-- --
-- This program is free software; you can redistribute it and/or modify --
-- it under the terms of the GNU General Public License as published by --
-- the Free Software Foundation; either version 2 of the License, or (at --
-- your option) any later version. --
-- --
-- This program is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
-- General Public License for more details. --
-- --
-- You should have received a copy of the GNU General Public License --
-- along with this library; if not, write to the Free Software Foundation, --
-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- You are not allowed to use any part of this code to develop a program --
-- whose output would be used to harass or prosecute other users of the --
-- networks Adagio connects with. All data collected with Adagio or a tool --
-- containing Adagio code about other network users must remain --
-- confidential and cannot be made public by any mean, nor be used to --
-- harass or legally prosecute these users. --
------------------------------------------------------------------------------
-- $Id: adagio-http-header.adb,v 1.3 2004/01/21 21:05:37 Jano Exp $
with Ada.Characters.Handling;
with Ada.Streams;
use Ada;
package body Adagio.Http.Header is
package ACH renames Ada.Characters.Handling;
-- Delete all members:
procedure Clear(this: out Set) is
begin
this.Response := Null_ustring;
Set_list.Clear(this.Data);
end Clear;
-- Add a pair:
-- If it already exists, will get replaced:
procedure Add(this: in out Set; Name, Value: String) is
begin
if Get(this, Name) = "" then
-- Addition
if Count(this) = Max_headers then
raise Constraint_error;
end if;
Set_list.Append (this.Data,
(Name => To_UString(Name), Value => To_UString(Value)));
else
-- Replacement
for i in Set_list.First(this.Data) .. Set_list.Last(this.Data) loop
declare
Target: String renames ACH.To_lower
(To_string(Set_list.Element(this.Data, i).Name));
begin
if Target = ACH.To_lower(Name) then
Set_list.Replace_element(this.Data, i,
(Name => To_ustring(Name), Value => To_ustring(Value)));
exit;
end if;
end;
end loop;
end if;
end Add;
-- Remove a pair:
procedure Delete(this: in out Set; Name: String) is
begin
for Pos in Set_list.First(this.Data) .. Set_list.Last(this.Data) loop
declare
E: Object renames Set_list.Element(this.Data, Pos);
begin
if ACH.To_lower(To_string(E.Name)) = ACH.To_lower(Name) then
Set_list.Delete(this.Data, Pos);
exit;
end if;
end;
end loop;
end Delete;
-- Get a value:
function Get(this: Set; Name: String) return String is
begin
for Pos in Set_list.First(this.Data) .. Set_list.Last(this.Data) loop
declare
E: Object renames Set_list.Element(this.Data, Pos);
begin
if ACH.To_lower(To_string(E.Name)) = ACH.To_lower(Name) then
return To_string(E.Value);
end if;
end;
end loop;
return "";
end Get;
-- Get number of headers:
function Count(this: in Set) return Natural is
begin
return Set_list.Length(this.Data);
end Count;
-- Any header?:
function Is_empty(this: in Set) return boolean is
begin
return Count(this) = 0;
end Is_empty;
-- Get all values as array:
function Headers(this: Set) return Object_array is
Result: Object_array(1 .. Count(this));
i: integer:= 1;
begin
for Pos in Set_list.First(this.Data) .. Set_list.Last(this.Data) loop
Result(i):= Set_list.Element(this.Data, Pos);
i:= i + 1;
end loop;
return Result;
end Headers;
-- Parse from a Stream
-- Will end after reading empty line
-- Will concatenate line-splitted headers
-- Will join as comma separated list multiple occurrences of a header
-- Optionally, will erase any previous headers:
procedure Parse
(this : in out Set;
Stream : access Ada.Streams.Root_stream_type'Class;
Read_response : Boolean := false;
Clean : Boolean := false) is
Pair: Object;
c, dummy: Character;
-- Will return the look-ahead character
function Peek_char return Character is
begin
return c;
end Peek_char;
-- Will return the next char and pre-fetch the next.
-- Take that into account to not read the ending character!
function Pop_char return Character is
aux: constant Character:= c;
begin
Character'Read(Stream, c);
return aux;
end Pop_char;
-- Will skip any whitespaces / continuation lines
procedure Skip_whitespaces is
begin
loop
if Peek_char = SP or else Peek_char = HT then
dummy:= Pop_char;
elsif Peek_char = CR then
dummy:= Pop_char;
if Pop_char /= LF then
raise Constraint_error;
end if;
if Peek_char /= SP and then Peek_char /= HT then
raise Constraint_error;
end if;
else
return;
end if;
end loop;
end Skip_whitespaces;
begin
if Clean then
Clear(this);
end if;
-- Get response:
if Read_response then
this.Response := U (Get_line (Stream));
end if;
-- Init look-ahead char:
Character'Read(Stream, c);
-- Skip leading CRLFs
while Peek_char = CR loop
dummy:= Pop_char;
if Pop_char /= LF then
raise Constraint_error;
end if;
end loop;
-- Main processing
Main: loop
-- Cleaning:
Pair.Name:= To_UString("");
Pair.Value:= To_UString("");
-- Complete a header name:
Name: loop
exit when Peek_char = ':';
if ASU.Length(Pair.Name) > Max_header_length then
raise Constraint_error;
end if;
ASU.Append(Pair.Name, Pop_char);
end loop Name;
-- Skip ':'
dummy:= Pop_char;
-- Skip whitespaces
Skip_whitespaces;
-- Read value
Value: loop
if Peek_char = CR then
dummy:= Pop_char; -- CR
if Pop_char /= LF then
raise Constraint_error;
end if;
-- Is a continuation line or value completed?
if Peek_char = SP or else Peek_char = HT then
Skip_whitespaces;
else -- completed value:
if Get(this, To_string(Pair.Name)) /= "" then
Add(this, To_string(Pair.Name),
Get(this, To_string(Pair.Name)) & ',' &
To_string(Pair.Value));
else
Add(this, To_string(Pair.Name), To_string(Pair.Value));
end if;
exit Main when Peek_char = CR;-- Second consecutive empty line
exit Value;
end if;
end if;
ASU.Append(Pair.Value, Pop_char);
end loop Value;
end loop Main;
-- Skip the trailing CRLF
dummy:= Pop_char;
if Peek_char /= LF then -- Not pop, last character already read
raise Constraint_error;
end if;
end Parse;
-- Send headers to some stream:
procedure Write
(this : in Set;
Stream : in out Ada.Streams.Root_stream_type'Class;
Send_response : Boolean := true;
Send_crlf : Boolean := false) is
begin
String'Write (Stream'Access, Write (This, Send_response, Send_crlf));
end Write;
-- Write headers to some string
-- The trailing empty line CRLF is not written.
function Write(
this : in Set;
Send_response : Boolean := true;
Send_crlf : Boolean := false) return String is
Result: Ustring;
begin
if Send_response then
Result := U (Get_response (This) & CRLF);
end if;
for Pos in Set_list.First(this.Data) .. Set_list.Last(this.Data) loop
declare
E: Object renames Set_list.Element(this.Data, Pos);
begin
Result:= Result & E.Name & ": " & E.Value & CRLF;
end;
end loop;
if Send_crlf then
Result := Result & CRLF;
end if;
return To_string(Result);
end Write;
-- Get the response string:
function Get_Response (this : Set) return String is
begin
return S (this.Response);
end Get_response;
procedure Set_response (this : in out Set; Response : String) is
begin
this.Response := U (Response);
end Set_response;
end Adagio.Http.Header;