File : adagio-g2-core-server_pool.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-core-server_pool.adb,v 1.3 2004/01/21 21:05:26 Jano Exp $
separate (Adagio.G2.Core)
protected body Server_pool is
-- Add a server:
-- Initially connecting!
procedure Add (this : in Server_access) is
begin
if this = null then
raise Constraint_error;
end if;
for N in Slots'Range loop
if not Slots (N).In_use then
Slots (N).In_use := true;
Slots (N).Server := this;
Slots (N).Status := Connecting;
Slots (N).Slot.Index := N;
-- Server reference
this.Slot := Slots (N).Slot'Unrestricted_access;
-- Done.
return;
end if;
end loop;
raise Storage_exhausted;
end Add;
-- Get a server by Id.
procedure Get (
Id : in String;
Status : in Server_status;
Server : out Server_access) is
begin
for N in Slots'Range loop
if Slots (N).In_use and then Core.Id (Slots (N).Server.all) = id
then
Server := Slots (N).Server;
return;
end if;
end loop;
Server := null;
end Get;
procedure Get (
Id : in UString;
Status : in Server_status;
Server : out Server_access) is
begin
Get (S (Id), Status, Server);
end Get;
-- Get a connected server by Id or null if not found:
function Get (Id : in UString; Status : in Server_status)
return Server_access is
begin
for N in Slots'Range loop
if Slots (N).In_use and then Core.Id (Slots (N).Server.all) = id
then
return Slots (N).Server;
end if;
end loop;
return null;
end Get;
-- Get all servers in a given status as array
function Get_array (Status : in Server_status) return Server_array is
Result : Server_array (1 .. Status_count (Status));
Pos : Natural := Result'First;
begin
for N in Slots'Range loop
if Slots (N).In_use and then
Slots (N).Status = Status
then
Result (Pos) := Slots (N).Server;
Pos := Pos + 1;
end if;
end loop;
return Result;
end;
-- Get all queues of connected servers but one (optional)
function Get_queues (But : in Server_access := null) return
Packet.Queue.Object_array is
Result : Packet.Queue.Object_array (1 .. Status_count (Connected));
Pos : Natural := Result'First;
begin
for N in Slots'Range loop
if Slots (N).In_use and then
Slots (N).Status = Connected and then
Slots (N).Server /= But
then
Result (Pos) := Slots (N).Slot.Outbound'Unrestricted_Access;
Pos := Pos + 1;
end if;
end loop;
return Result (1 .. Pos - 1);
end Get_queues;
-- As previous but with addresses too:
function Get_Queues_And_Addresses (But : in Server_Access := null)
return Packet.Queue.Address_Queue_Array
is
Result : Packet.Queue.Address_Queue_Array (1 .. Status_count (Connected));
Pos : Natural := Result'First;
begin
for N in Slots'Range loop
if Slots (N).In_use and then
Slots (N).Status = Connected and then
Slots (N).Server /= But
then
Result (Pos).Queue := Slots (N).Slot.Outbound'Unrestricted_Access;
Result (Pos).Address := Slots (N).Server.Address & ":" & Misc.To_String (Slots (N).Server.Port);
Pos := Pos + 1;
end if;
end loop;
return Result (1 .. Pos - 1);
end Get_queues_And_Addresses;
-- Get next server:
-- Will return null if no more:
-- will check-in the current server.
-- Will skip checked-out servers.
procedure Get_next (Server : in out Server_access) is
begin
if Server = null or else
Server.Slot = null or else
Server.Slot.Index not in Try_range
then
Get_first (Server);
return;
end if;
for N in Server.Slot.Index + 1 .. Try_range'Last loop
if Slots (N).In_use then
Server := Slots (N).Server;
return;
end if;
end loop;
Server := null;
end Get_next;
-- Get first server:
-- Will return null if no more:
procedure Get_first (Server : out Server_access) is
begin
for N in Try_range'Range loop
if Slots (N).In_use then
Server := Slots (N).Server;
return;
end if;
end loop;
Server := null;
end Get_first;
-- Get newest connected server:
procedure Get_newest (Server : out Server_access) is
Newest : Natural := 0;
Connect_time : Calendar.Time := Calendar.Time_of (1976, 9, 6);
begin
for N in Try_range'Range loop
if Slots (N).In_use and then Slots (N).Status = Connected then
if Slots (N).Server.Connection_start > Connect_time then
Newest := N;
Connect_time := Slots (N).Server.Connection_start;
end if;
end if;
end loop;
if Newest = 0 then
Server := null;
else
Server := Slots (Newest).Server;
end if;
end Get_newest;
-- Count valid servers in any active (not disconnected) status:
function Active_count return Natural is
Result : Natural := 0;
begin
for N in Slots'Range loop
if Slots (N).In_use and then Slots (N).Status /= Disconnected then
Result := Result + 1;
end if;
end loop;
return Result;
end;
-- Count used slots:
function Count return Natural is
Result : Natural := 0;
begin
for N in Slots'Range loop
if Slots (N).In_use then
Result := Result + 1;
end if;
end loop;
return Result;
end Count;
-- Count valid servers in a given status:
function Status_count (Status : in Server_status) return Natural is
Result : Natural := 0;
begin
for N in Slots'Range loop
if Slots (N).In_use and then Slots (N).Status = Status then
Result := Result + 1;
end if;
end loop;
return Result;
end Status_count;
-- Remove a server.
procedure Remove (Server : in out Server_access) is
P : Natural renames Server.Slot.Index;
begin
if not Slots (P).In_use then
raise Constraint_error;
end if;
Slots (P).In_use := false;
Server.Slot := null;
Server := null;
end Remove;
-- Disconnect all servers, without pity, regardeless of checking!
procedure Disconnect_all is
begin
for N in Slots'Range loop
if Slots (N).In_use then
Socket.Close (Slots (N).Slot.Socket);
end if;
end loop;
end Disconnect_all;
-- Read status:
function Status (Server : in Server_access) return Server_status is
begin
return Slots (Server.Slot.Index).Status;
exception
when others =>
return Disconnected;
end Status;
-- Set status:
procedure Set_status (
Server : in Server_access;
Status : in Server_status) is
begin
Slots (Server.Slot.Index).Status := Status;
exception
when E : others =>
Trace.Log ("G2.Core.Server_pool.Set_status: " & Trace.Report (E),
Trace.Debug);
end Set_status;
-- Get an array of readable addresses of connected neighbours:
function Address_list return Ustring_array is
Result : Ustring_array (1 .. Status_count (Connected));
Pos : Natural := 1;
begin
for N in Slots'Range loop
if Slots (N).In_use and then Slots (N).Status = Connected then
Result (Pos) :=
Slots (N).Server.Address & ":" &
Misc.To_string (Slots (N).Server.Port);
Pos := Pos + 1;
end if;
end loop;
return Result;
end Address_list;
-- Get a report of all servers:
function Report return Report_array is
Result : Report_array (1 .. Count);
Pos : Positive := 1;
begin
for N in Slots'Range loop
if Slots (N).In_use then
Result (Pos).Uptime := Natural (
Calendar.Clock - Slots (N).Server.Connection_start);
Result (Pos).Status := U (
Server_status'Image (Slots (N).Status));
Result (Pos).Id := U (Describe (Slots (N).Server.all));
Pos := Pos + 1;
end if;
end loop;
return Result;
end Report;
end Server_pool;