File : adagio-server.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-server.adb,v 1.4 2004/02/05 18:31:22 Jano Exp $
with Adagio.Globals;
with Adagio.Misc;
with Adagio.Statistics;
with Adagio.Statistics.Integers;
with Adagio.Trace;
with Agpl.Strings;
with Ada.Calendar; use Ada;
with Ada.Exceptions;
with Ada.Streams.Stream_IO;
with Ada.Unchecked_deallocation;
with Gnat.Os_lib; use Gnat;
with Charles.Multimaps.Sorted.Unbounded;
package body Adagio.Server is
Stat_cached_hubs : constant String := "Servers - Cached";
use type Server_list.Iterator_type;
use type Ada.Calendar.Time;
Minimum_idle_period : Duration := 120.0;
Stat_allocated_servers : constant String := "Network - Allocated servers";
-- Helper function to compare Object_access:
function Equal(Left, Right: in Server_slot) return boolean is
begin
return Id(Left.Server.all) = Id(Right.Server.all);
end Equal;
package Sorted_list is new Charles.Multimaps.Sorted.Unbounded(
Rating, Server_slot_access, ">", "=");
use type Sorted_list.Iterator_type;
-- Direct access to slots in use:
function Get_ref is new
Server_list.Generic_element(Server_slot_access);
-- Delete a pointed object:
procedure Free (this: in out Object_access) is
procedure Free_local is new
Unchecked_deallocation(Object'Class, Object_access);
begin
Free_local (this);
end Free;
------------------------------------------------------------------------
-- Controlled procedures --
------------------------------------------------------------------------
procedure Initialize (This : in out Object) is
pragma Unreferenced (This);
begin
-- This.Initialized := true;
-- Trace.Log ("====>");
-- Statistics.Object.Update (
-- Stat_allocated_servers,
-- Statistics.Integers.Increment'Access,
-- Statistics.Integers.Create (1));
null;
end Initialize;
procedure Adjust (This : in out Object) is
pragma Unreferenced (This);
begin
-- Trace.Log ("=***=");
null;
end Adjust;
procedure Finalize (This : in out Object) is
pragma Unreferenced (This);
begin
-- if This.Initialized then
-- This.Initialized := false;
-- Statistics.Object.Update (
-- Stat_allocated_servers,
-- Statistics.Integers.Increment'Access,
-- Statistics.Integers.Create (-1));
-- end if;
-- Trace.Log ("<====");
null;
end Finalize;
-- List of servers:
protected body List is
-- Add
procedure Add (
This : in out Object_access;
Since : in Calendar.Time := Calendar.Clock)
is
begin
-- If present, error:
if Server_list.Is_in (Id(this.all), Servers) then
Free (This);
raise Server_already_cached;
else
Server_list.Insert(
Servers, Id(this.all),
(this, true, Calendar.Clock, Since));
-- Trace.Log("Server.List.Add: " & Id(this.all) & " added to cache");
end if;
Dirty:= true;
Statistics.Object.Set (Stat_cached_hubs,
Statistics.Integers.Create (Server_list.Length (Servers)));
end Add;
-- Remove a server
-- Freeing it is responsability of the caller!
procedure Delete(this: in Object_access) is
begin
Server_list.delete(Servers, Id(this.all));
Statistics.Object.Set (Stat_cached_hubs,
Statistics.Integers.Create (Server_list.Length (Servers)));
end Delete;
-- Drop a server by Id. It's freed and deleted. If checked out,
-- success will be false. Also if not found.
procedure Drop (This : in String; Success : out Boolean) is
use Server_list;
Server : Object_access;
Pos : Iterator_type := Find (Servers, This);
begin
Success := Pos /= Back (Servers);
if Success then
Success := Element (Pos).Available;
if Success then
Server := Element (Pos).Server;
Delete (Server);
Free (Server);
end if;
end if;
end Drop;
-- Returns server to available mode.
procedure Check_in(this: in Object_access) is
Serv: Server_slot_access renames
Get_ref(Server_list.Find(Servers, Id(this.all)));
begin
if Serv.Available then
raise Constraint_error;
else
Serv.Available:= true;
Serv.Last_check_in := Calendar.Clock;
end if;
end Check_in;
-- Dump:
procedure Serialize(Stream: in Stream_access) is
procedure Check(Item: Server_slot) is
begin
Calendar.Time'Output (Stream, Item.Since);
Object'Class'Output(Stream, Item.Server.all);
end Check;
procedure Do_check is new Server_list.Generic_select_elements(Check);
begin
-- Dump number:
Integer'Write(Stream, Server_list.Length(Servers));
Do_check (Server_list.First(Servers), Server_list.Back(Servers));
end Serialize;
-- Restore:
procedure Restore(Stream: in Stream_access) is
Num : Integer;
Since : Calendar.Time;
begin
-- Read number:
Integer'Read(Stream, Num);
-- Restore servers:
for n in 1 .. Num loop
Since := Calendar.Time'Input (Stream);
declare
Serv: Object_access:=
new Object'Class'(Object'Class'Input(Stream));
begin
Add (Serv, Since);
-- Server_list.Insert(
-- Servers, Id(Serv.all), (Serv, true, Calendar.Clock));
exception
when Server_already_cached =>
null;
end;
end loop;
Statistics.Object.Set (Stat_cached_hubs,
Statistics.Integers.Create (Server_list.Length (Servers)));
end Restore;
-- Startup
procedure Initialize is
use Streams.Stream_IO;
Location: String:= S (Globals.Data_folder) & "hostcache.dat";
F : File_type;
T : Calendar.Time:= Calendar.Clock;
Success : Boolean;
use type Calendar.Time;
begin
if Os_lib.Is_regular_file (Location & ".tmp") and not
Os_lib.Is_regular_file (Location) then
Os_lib.Rename_file (Location & ".tmp", Location, Success);
end if;
if Os_lib.Is_regular_file(Location) then
Open(F, Name => Location, Mode => In_file);
Restore(Stream_access(Stream(F)));
Close(F);
else
Trace.Log("Server.List.Initialize: " & Location &
" doesn't exists.");
Dirty:= false;
return;
end if;
Trace.Log("Server.List.Initialize: " & Location &
" loaded correctly (" & Duration'Image(Calendar.Clock - T) & "s)");
Dirty:= false;
exception
when E: others =>
if Is_open(F) then
Close(F);
Trace.Log
("Server.List.Initialize (loading): " & Trace.Report(E),
Trace.Error);
end if;
Server_list.Clear (Servers);
end Initialize;
-- Saving (if needed):
procedure Save is
use Streams.Stream_IO;
F: File_type;
T: Calendar.Time:= Calendar.Clock;
Success: Boolean;
Location: String:= S (Globals.Data_folder) & "hostcache.dat";
use type Calendar.Time;
begin
if not Dirty then
return;
end if;
-- Try to delete a temp failed:
if Os_lib.Is_regular_file(Location & ".tmp") then
Os_lib.Delete_file(Location & ".tmp", Success);
if not Success then
Exceptions.Raise_exception
(Storage_error'identity, "Cannot delete temp file.");
end if;
end if;
Create(F, Name => Location & ".tmp");
Serialize(Stream_access(Stream(F)));
Close(F);
-- Delete old hostcache
if Os_lib.Is_regular_file(Location) then
Os_lib.Delete_file(Location, Success);
if not Success then
Exceptions.Raise_exception
(Storage_error'identity, "Cannot delete old hostcache.");
end if;
end if;
Os_lib.Rename_file(Location & ".tmp", Location, Success);
if not Success then
Exceptions.Raise_exception
(Storage_error'identity, "Cannot rename saved temp file.");
end if;
Trace.Log("Server.List.Save: " & Location & " saved correctly (" &
Duration'Image(Calendar.Clock - T) & "s)");
Dirty:= false;
exception
when E: others =>
if Is_open(F) then
Close(F);
end if;
Trace.Log("Server.List.Save: " & Trace.Report(E), Trace.Error);
end Save;
-- Purge servers dropables and not in use:
procedure Purge is
Pos: Server_list.Iterator_type:= Server_list.First(Servers);
Serv: Object_access;
begin
while Pos /= Server_list.Back(Servers) loop
if Server_list.Element(Pos).Available and then
Dropable (Server_list.Element(Pos).Server.all) and then
Calendar.Clock - Server_list.Element(Pos).Last_check_in >
Minimum_idle_period
then
-- Get reference:
Serv:= Server_list.Element(Pos).Server;
-- Advance to safe position:
Pos:= Server_list.Succ (Pos);
Trace.Log("Server.List.Purge: " & Id(Serv.all) & " purged");
-- Remove:
Server_list.Delete(Servers, Id(Serv.all));
-- Free:
Free (Serv);
else
Pos:= Server_list.Succ (Pos);
end if;
end loop;
Dirty:= true;
Statistics.Object.Set (Stat_cached_hubs,
Statistics.Integers.Create (Server_list.Length (Servers)));
exception
when E: others =>
Trace.Log("Server.List.Purge: " & Trace.Report(E), Trace.Error);
end Purge;
-- Purge servers from a particular network,
-- keeping at most some quantity:
procedure Purge (Net: String; Keep: Natural) is
Sorted : Sorted_list.Container_type;
Pos : Server_list.Iterator_type:= Server_list.First(Servers);
Poss : Sorted_list.Iterator_type;
Pos_num: Natural:= 0;
SS : Object_access;
begin
if Available(Net) <= Keep then
return;
end if;
-- Do a ordered copy:
Trace.Log ("Server.Purge (Keep) starting for " & Net);
while Pos /= Server_list.Back(Servers) loop
declare
Serv: Server_slot_access:= Get_ref(Pos);
begin
if Serv.Available and then
Server.Net(Serv.Server.all) = Net and then
Calendar.Clock - Serv.Last_check_in > Minimum_idle_period
then
-- Copy it into targetted servers:
Sorted_list.Insert(Sorted, Rate(Serv.Server.all), Serv);
end if;
end;
Pos:= Server_list.Succ (Pos);
end loop;
Trace.Log ("Server.Purge (Keep) in progress for " & Net);
-- Delete any excess servers:
Poss:= Sorted_list.First(Sorted);
while Poss /= Sorted_list.Back(Sorted) loop
Pos_num:= Pos_num + 1;
if Pos_num > Keep then
-- Get server
SS := Sorted_list.Element (Poss).Server;
-- Delete from original list
List.Delete(SS);
-- Free it:
Free (SS);
end if;
Poss:= Sorted_list.Succ (Poss);
end loop;
Trace.Log("Server.Purge (Keep) done for network " & Net &
", dropped" & Integer'Image (
Integer'Max (0, Pos_num - Keep)) & " servers.");
Dirty:= true;
Statistics.Object.Set (Stat_cached_hubs,
Statistics.Integers.Create (Server_list.Length (Servers)));
exception
when E: others =>
Trace.Log("Server.Purge(Keep): " & Trace.Report(E), Trace.Error);
end Purge;
-- Available servers from a given net:
function Available(Net: String) return Natural is
Total: Natural:= 0;
procedure Check(Item: Server_slot) is
begin
if Server.Net(Item.Server.all) = Net then
Total:= Total + 1;
end if;
end Check;
procedure Do_check is new Server_list.Generic_select_elements(Check);
begin
Do_check(Server_list.First(Servers), Server_list.Back(Servers));
return Total;
end Available;
-- Obtain the N best servers for a network:
function Get_best(Net: String; Quantity: Positive)
return Object_access_array is
-- We'll sort the servers by inserting it in a ordered list.
Null_result: Object_access_array(1 .. 0);
Sorted: Sorted_list.Container_type;
procedure Copy(Item: in Server_slot_access) is
begin
if Item.Available and then Server.Net(Item.Server.all) = Net
and then Is_Ready (Item.Server.all)
then
Sorted_list.Insert(Sorted, Rate(Item.Server.all), Item);
end if;
end Copy;
Pos: Server_list.Iterator_type:= Server_list.First(Servers);
use type Server_list.Iterator_type;
begin
-- Do sort:
while Pos /= Server_list.Back(Servers) loop
Copy(Get_ref(Pos));
Pos:= Server_list.Succ(Pos);
end loop;
-- Nothing found?
if Sorted_list.Is_empty(Sorted) then
return Null_result;
else
declare
Pos: Sorted_list.Iterator_type:= Sorted_list.First(Sorted);
use type Sorted_list.Iterator_type;
Result: Object_access_array(1 .. Quantity);
Len: Natural:=
Natural'Min(Result'last, Sorted_list.Length(Sorted));
begin
for n in 1 .. Len loop
-- Check out server:
Sorted_list.Element(Pos).Available:= false;
Result(n):= Sorted_list.Element(Pos).Server;
Pos:= Sorted_list.succ(Pos);
end loop;
return Result(1 .. Len);
exception
when E: others =>
Trace.Log("Server.Get_best: Error building result (1): " &
Trace.Report(E), Trace.Error);
return Null_result;
end;
end if;
exception
when E: others =>
Trace.Log("Server.Get_best: Error building result (2): " &
Trace.Report(E), Trace.Error);
return Null_result;
end Get_best;
-- Http_report:
procedure Http_report (
Data : out Agpl.Http.Server.Sort_handler.Data_set)
is
use Agpl.Http.Server.Sort_Handler;
use Ada.Calendar;
use Server_list;
I : Iterator_type := First (Servers);
begin
while I /= Back (Servers) loop
declare
Row : Data_row;
Serv : Object_access renames Element (I).Server;
Uid : Ustring := U (Id (Serv.all));
Netw : Ustring := U (Net (Serv.all));
Rat : Float := Rate (Serv.all);
Drop : Ustring := U (Boolean'Image (Dropable (Serv.all)));
Used : Ustring := U (Boolean'Image (not Element(I).Available));
Sinc : Duration:= Clock - Element (I).Since;
Redy : Ustring := U (Boolean'Image (Is_Ready (Serv.all)));
begin
-- Address
Append (Row, (Uid, Uid));
-- Network
Append (Row, (Netw, Netw));
-- Rating
Append (Row, (
U (Agpl.Strings.To_string (Rat, 2)),
Rpad (Rat, 16)));
-- In use
Append (Row, (Used, Used));
-- Dropable
Append (Row, (Drop, Drop));
-- Since
Append (Row, (
U (Misc.Image (Sinc)),
Rpad (Float (Sinc), 16)));
-- Ready
Append (Row, (Redy, Redy));
Append (Data, Row);
end;
I := Succ (I);
end loop;
end Http_report;
end List;
begin
null;
-- Statistics.Object.Set (
-- Stat_allocated_servers,
-- Statistics.Integers.Create (0));
end Adagio.Server;