File : adagio-g2-packet.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-g2-packet.adb,v 1.7 2004/02/29 20:36:42 Jano Exp $
with Adagio.Memory_stream_constrained;
with Adagio.Misc;
with Adagio.Network.Endian;
with Adagio.Socket;
with Adagio.Trace;
with Ada.Unchecked_conversion;
with Ada.Unchecked_deallocation; use Ada;
package body Adagio.G2.Packet is
Stat_num_children : constant String := "Network - G2 - Alive packets";
use type Safe_child.Object;
package Child_vector is new Agpl.Dynamic_vector (Object);
-- Lazyness:
function V (this : in Object) return Child_access
renames Safe_child.Value;
function Length (this : in Children_vector.Object) return Integer
renames Children_vector.Length;
-- Returns the head kind of a packet : Head ("/PI/PO") returns "PI"
function Head (S : String) return String;
-- Returns the tail kind of a packet : Head ("/PI/PO") returns "/PO"
function Tail (S : String) return String;
-- Create a packet with given name and payload:
-- Returns an allocated object
function Create (Name : in String; Payload : in String := "")
return Object is
C : Child_access := new Child;
P : Object;
begin
C.Type_name := B (Name);
C.Control_byte.Name_len := Name'Length - 1;
C.Payload := U (Payload);
Safe_child.Bind (P, C);
return P;
end Create;
-- Serialization of that control byte:
procedure Write (
Stream : access Streams.Root_stream_type'Class;
this : Control_byte_type) is
function To_byte is new
Unchecked_conversion (Control_byte_type, Byte);
begin
Byte'Write (Stream, To_byte (this));
end Write;
-- Fully reads a packet from a stream. Allocates it.
procedure Read(
Stream : access Streams.Root_stream_type'Class;
this : out Control_byte_type) is
function To_control is new
Unchecked_conversion (Byte, Control_byte_type);
B : Byte;
begin
Byte'Read (Stream, B);
this := To_control (B);
end Read;
-- Serialization of packets:
procedure Serialize(
Stream : access Streams.Root_stream_type'Class;
this : Object) is
begin
raise Unimplemented;
end Serialize;
-- Fully reads a packet from a stream. Allocates it.
procedure Read(
Stream : access Streams.Root_stream_type'Class;
this : out Packet.Object) is
begin
raise Unimplemented;
end Read;
-- Debug only:
procedure Initialize (This : in out Child) is
begin
null;
-- Statistics.Object.Update (
-- Stat_num_children,
-- Statistics.Integers.Increment'Access,
-- Statistics.Integers.Create (1));
end Initialize;
-- Recursively frees any children
procedure Finalize (this : in out Child) is
begin
for N in 1 .. Length (this.Children) loop
Free (this.Children.Vector (N));
end loop;
-- Statistics.Object.Update (
-- Stat_num_children,
-- Statistics.Integers.Increment'Access,
-- Statistics.Integers.Create (-1));
end Finalize;
-- Delete a packet:
procedure Free (this : in out Child_access) is
procedure Delete is new Unchecked_deallocation(Child, Child_access);
begin
Delete (this);
end Free;
------------------------------------------------------------------------
-- Clone --
------------------------------------------------------------------------
-- Deep copy: Clone a child and all its children
function Clone (this : in Child_access) return Child_access is
Result : Child_access := new Child;
begin
Result.Control_byte := This.Control_byte;
Result.Len := This.Len;
Result.Type_name := This.Type_name;
Result.Payload := This.Payload;
Result.Arrival_time := This.Arrival_time;
Result.Children := This.Children; -- To get the same length
-- Now clone children
for N in 1 .. Length (This.Children) loop
Result.Children.Vector (N) := Clone (This.Children.Vector (N));
end loop;
return Result;
end Clone;
-- Adds a child to a packet:
-- May raise exception if too many childs
procedure Add_child (
Parent : in Child_access;
New_child : in out Child_access) is
begin
-- Check null:
if New_child = null then
return;
end if;
-- Add it:
begin
Parent.Control_byte.Compound_flag := true;
if Length (Parent.Children) = MAX_CHILDREN then
raise Constraint_error;
end if;
if S (New_child.Type_name) = "TO" then
Children_vector.Insert (
Parent.Children, New_child, Parent.Children.Vector'First);
else
Children_vector.Append (Parent.Children, New_child);
end if;
New_child := null;
exception
when Constraint_error =>
Trace.Log("G2.Packet.Add_child: Dropping child " &
"(max reached). Max is" & Integer'Image (MAX_CHILDREN), Trace.Warning);
Trace.Log("Packet: " & S (Parent.Type_Name), Trace.Warning);
Free (New_child);
end;
end Add_child;
-- Full size of a packet, including:
-- control byte, len, name, children, payload.
function Full_size (this : in Child_access) return Natural is
begin
return
1 + -- Control_byte
this.Control_byte.Len_len + -- Len
this.Control_byte.Name_len + 1 + -- Name
this.Len; -- Children + Payload
end Full_size;
-- Full size of children packets of a packet:
function Children_size (this : in Child_access) return Natural is
Size : Natural := 0;
begin
for n in 1 .. Length (this.Children) loop
Size := Size + Full_size (this.Children.Vector (n));
end loop;
return Size;
end Children_size;
-- Makes an object into child of another one.
-- May raise exception if too many childs
-- Doesn't check for duplicates.
-- Check null additions (no effect).
procedure Add_child (Parent: in Object; New_child : in out Object) is
C : Child_access := V (New_child);
begin
-- Prevent releasing:
Safe_child.Unbind (New_child);
New_child := Null_packet;
-- Add normally:
Add_child (V (Parent), C);
end Add_child;
-- Root name of a packet:
function Name (this : in Object) return String is
begin
return BStrings.To_string (V (this).Type_name);
end Name;
-- Root payload as a string:
function Payload (this : in Object) return String is
begin
return S (V (this).Payload);
end Payload;
-- Arrival time:
function Arrival_time (this : in Object) return Calendar.Time is
begin
return V (this).Arrival_time;
end Arrival_time;
-- Big endian?
function Big_endian (this: in Object) return Boolean is
begin
return V (this).Control_byte.Big_endian;
end Big_endian;
-- Hex representation of a packet:
function To_hex (this : in Object; Interleaving : String := " ")
return String is
function To_char is new Unchecked_conversion
(Control_byte_type, Character);
Result : UString;
C : Child_access := V (this);
begin
-- Control byte:
Result := U (Misc.To_hex (To_char (C.Control_byte))) & Interleaving;
-- Length:
Result := Result & Misc.To_string (C.Len) & Interleaving;
-- Name:
Result := Result & S (C.Type_name) & Interleaving;
-- Payload:
declare
Payload : String := S (C.Payload);
begin
for n in Payload'Range loop
Result := Result & Misc.To_hex(Payload (n));
end loop;
end;
return S (Result);
end To_hex;
-- Enumeration of children in a packet:
function To_Text (
This : in Object; Show_Payloads : in Boolean := false) return String
is
function To_Text (This : in Child_Access; Show_Payloads : in Boolean) return String
is
Line : Ustring := U (S (This.Type_Name));
begin
if Show_Payloads then
Asu.Append (Line, ":");
Asu.Append (Line, This.Payload);
end if;
for n in 1 .. Children_vector.Length (this.Children) loop
Asu.Append (Line, "->");
Asu.Append (Line, To_Text (this.Children.Vector (n), Show_Payloads));
end loop;
Asu.Append (Line, ";");
return S (Line);
end To_Text;
begin
return To_Text (Safe_Child.Value (This), Show_Payloads);
end To_Text;
-- Is_a: says if a packet qualifies for some kind.
-- Should have initial / (i.e: /PI/UDP)
function Is_a (this : in Object; Kind : in String) return Boolean is
begin
return Is_a (V (this), Kind);
end Is_a;
-- Is_a: says if a packet qualifies for some kind.
-- Should have initial / (i.e: /PI/UDP)
function Is_a (this : in Child_access; Kind : in String) return Boolean is
begin
if Kind = "" then
return true;
end if;
if Head (Kind) /= S (this.Type_name) then
return false;
end if;
-- Check all children
declare
T : String := Tail (Kind);
begin
if T = "" then
return true;
else
for N in 1 .. Length (this.Children) loop
if Is_a (this.Children.Vector (N), T) then
return true;
end if;
end loop;
-- Not found, hence:
return false;
end if;
end;
end Is_a;
-- Get a given child from an object
-- Name is in the form "xx/yy/zz"
-- Must be unique
function Get_child (this : in Child_access; Name : in String)
return Child_access is
H : String := Head ("/" & Name);
T : String := Tail (Name);
Found : Boolean := false;
C : Child_access;
begin
-- Search current one:
for N in 1 .. Length (this.Children) loop
if S (this.Children.Vector (N).Type_name) = H then
C := this.Children.Vector (N);
if Found then
raise Constraint_error;
else
Found := true;
end if;
end if;
end loop;
-- Null if not found
if C = null then
return null;
end if;
if T = "" then
return C;
else
return Get_child (C, T (T'First + 1 .. T'Last));
end if;
end Get_child;
-- Returns a child as an object
-- Will raise Constraint_error if that child appears multiple times
-- Name is in the form "xx/yy/zz"
function Get_child (this : in Object; Name : in String) return Object is
C : Child_access;
Result : Object;
begin
C := Get_child (V (this), Name);
if C = null then
Result := Null_packet;
else
-- Duplicate it to not have safe and unsafe refs to the same child:
Safe_child.Bind (Result, Clone (C));
end if;
return Result;
end;
------------------------------------------------------------------------
-- Get_children --
------------------------------------------------------------------------
-- Get children of a given type. Inmediate depth only.
function Get_children (this : in Object; Name : in String)
return Object_array is
R : Child_vector.Object (First => 1);
C : Object;
begin
for N in 1 .. Length (V (this).Children) loop
if S (V (this).Children.Vector (N).Type_name) = Name then
Safe_child.Bind (C, Clone (V (this).Children.Vector (N)));
Child_vector.Append (R, C);
end if;
end loop;
return Object_array (R.Vector (1 .. Child_vector.Length (R)));
end Get_children;
-- Returns the expected length of child + payload
-- That's the length of CHILDREN + \0 SEPARATOR IF NEEDED + PAYLOAD
function Computed_length (this : in Child) return Natural is
Result : Natural := 0;
Len : Natural := Length (this.Children); -- The number of children,
-- not its size.
begin
-- Simple packet
if Len = 0 and then this.Payload = Null_payload then
return 0;
elsif Len > 0 and then this.Payload = Null_payload then
-- Only children, we can adjust the size without trailing \0
for N in 1 .. Len loop
Result := Result + Full_length (this.Children.Vector (N).all);
end loop;
elsif Len = 0 and then this.Payload /= Null_payload then
return ASU.Length (this.Payload);
else
-- Children plus payload:
for N in 1 .. Len loop
Result := Result + Full_length (this.Children.Vector (N).all);
end loop;
Result := Result + 1; -- The \0 marker for end-of-childs
Result := Result + ASU.Length (this.Payload); -- Payload
end if;
return Result;
end Computed_length;
-- Returns the expected full length (control + len_len + name_len + etc)
-- That's the FULL LENGTH OF THIS CHILD, HEADERS PLUS ITS CHILDREN
function Full_length (this : in Child) return Natural is
begin
return
1 +
Len_len (Computed_length (this)) +
Computed_length (this) +
this.Control_byte.Name_len + 1;
end Full_length;
-- Returns the expected full length (control + len_len + name_len + etc)
function Full_length (this : in Object) return Natural is
begin
return Full_length (V (this).all);
end Full_length;
-- Return the number of bytes neccesaries to carry this number:
function Len_len (N : Natural) return Natural is
begin
if N = 0 then
return 0;
elsif N < 2 ** 8 then
return 1;
elsif N < 2 ** 16 then
return 2;
else
return 3;
end if;
end;
-- Writing to stream.
procedure Write (
Stream : access Streams.Root_stream_type'Class; this : in Object) is
begin
Write (Stream, V (this).all);
end Write;
-- Writing to stream.
procedure Write (
Stream : access Streams.Root_stream_type'Class; this : in Child) is
Control_byte : Control_byte_type := this.Control_byte;
Length : Natural := Computed_length (this);
Length_array : Network.Endian.Byte_array :=
Network.Endian.Convert (Length, Control_byte.Big_endian);
-- Preserve endianness, in case payload needs it.
begin
Control_byte.Len_len := Length_array'Length;
-- Watch to not send a \0:
if Control_byte.Len_len = 0 then
Control_byte.Compound_flag := true;
end if;
-- Send control_byte
Control_byte_type'Write (Stream, Control_byte);
-- Send length (maybe an empty array, so nothing is sent).
Network.Endian.Byte_array'Write (Stream, Length_array);
-- Send name
String'Write (Stream, S (this.Type_name));
-- Send childs
for N in 1 .. Children_vector.Length (this.Children) loop
Write (Stream, this.Children.Vector (N).all);
end loop;
-- Send \0 if needed
if Control_byte.Compound_flag and then this.Payload /= Null_payload then
Network.Endian.Byte'Write (Stream, 0);
end if;
-- Send payload;
if this.Payload /= Null_payload then
String'Write (Stream, S (this.Payload));
end if;
end Write;
-- Atomic writing to a socket stream. It guarantees that the entire
-- packet is written (or not a byte) in a non-blocking socket stream.
procedure Atomic_Write (
Stream : access Streams.Root_stream_type'Class;
This : in Object;
Success : out Boolean)
is
use Streams;
Buffer : aliased Stream_element_array (
1 .. Stream_element_offset (Full_length (This)));
BStream : aliased Memory_stream_constrained.Stream_type;
begin
Memory_stream_constrained.Create (
BStream, Buffer'Address, Buffer'Length);
Write (Streams.Root_stream_type'Class (Bstream)'access, This);
Write (Stream.all, Buffer);
Success := true;
exception
when E : Socket.Socket_error =>
case Socket.Get_error (E) is
when Socket.Operation_would_block =>
Success := false;
when others =>
raise;
end case;
end Atomic_write;
-- Deep copy: Clone an object and all its children
function Clone (this : in Object) return Object is
O : Object;
begin
Safe_child.Bind (O, Clone (V (this)));
return O;
end Clone;
---------------
-- Utilities --
---------------
-- Returns the head kind of a packet : Head ("/PI/PO") returns "PI"
function Head (S : String) return String is
begin
for N in S'First + 1 .. S'Last loop
if S (N) = '/' then
return S (S'First + 1 .. N - 1);
end if;
end loop;
return S (S'First + 1 .. S'Last);
end Head;
-- Returns the tail kind of a packet : Head ("/PI/PO") returns "/PO"
function Tail (S : String) return String is
begin
for N in S'First + 1 .. S'Last loop
if S (N) = '/' then
return S (N .. S'Last);
end if;
end loop;
return "";
end Tail;
begin
-- Statistics.Object.Set (
-- Stat_num_children, Statistics.Integers.Create (0));
null;
end Adagio.G2.Packet;