File : adagio-g2-search.ads
------------------------------------------------------------------------------
-- 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.ads,v 1.19 2004/03/29 19:13:30 Jano Exp $
-- Now leaks the queues array, no finalization method.
with Adagio.G2.Packet.Queue;
with Adagio.G2.Transceiver;
with Adagio.Globals.Options;
with Adagio.Searches.Handler;
with Adagio.Searches;
with Agpl.Event_Queues.Calendar;
with Agpl.Http.Server.Sort_Handler;
use Agpl.Http.Server.Sort_Handler;
with Charles.Multimaps.Sorted.Unbounded;
with Charles.Maps.Sorted.Strings.Unbounded;
with Ada.Calendar;
use Ada;
package Adagio.G2.Search is
-- Searches are event-driven. Unscheduled hubs are programmed an event and marqued as
-- scheduled. Once the event triggers, the hubs are marked as unscheduled, and await
-- a QKA. The QKA triggers the launching of a Q2, if there are searches for the hub.
-- If not, it is rescheduled with the MinimumRest delay.
-- Once a QA arrives, the hub is rescheduled with Max (MinimumRest, RemoteBan)
------------------------------------------------------------------------
-- Object --
------------------------------------------------------------------------
type Object is new Searches.Handler.Object with private;
type Object_access is access all Object;
------------------------------------------------------------------------
-- Create_Search --
------------------------------------------------------------------------
-- Notify the creation of a new search
procedure Create_Search (
This : access Object; Target : in Searches.Search_Id);
------------------------------------------------------------------------
-- Delete_Search --
------------------------------------------------------------------------
procedure Delete_Search (
This : access Object; Target : in Searches.Search_Id);
------------------------------------------------------------------------
-- Get_Custom_Info --
------------------------------------------------------------------------
-- Intended to allow each network to provide some progress info.
function Get_Custom_Info (
This : access Object; Target : in Searches.Search_Id) return String;
------------------------------------------------------------------------
-- Get_Hubs --
------------------------------------------------------------------------
-- Alive ones
function Get_Hubs (This : access Object) return Natural;
-- Tracked ones
function Get_Tracked_Hubs (This : access Object) return Natural;
------------------------------------------------------------------------
-- Get_Latency --
------------------------------------------------------------------------
-- Latency of the remote search (minimum wait locally imposed on new events).
function Get_Latency (This : access Object) return Duration;
------------------------------------------------------------------------
-- Get_Leaves --
------------------------------------------------------------------------
function Get_Leaves (This : access Object) return Natural;
------------------------------------------------------------------------
-- Http_Report --
------------------------------------------------------------------------
procedure Http_Report (This : access Object; Data : out Data_Set);
------------------------------------------------------------------------
-- Process_Search_Packet --
------------------------------------------------------------------------
procedure Process_Search_Packet (
This : access Object; Item : G2.Packet.Queue.Item_Type);
------------------------------------------------------------------------
-- Set_Paused --
------------------------------------------------------------------------
procedure Set_Paused (
This : access Object;
Target : in Searches.Search_Id;
Paused : in Boolean := true);
------------------------------------------------------------------------
-- Set_Priority --
------------------------------------------------------------------------
procedure Set_Priority (
This : access Object;
Target : in Searches.Search_Id;
Priority : in Searches.Priorities);
------------------------------------------------------------------------
-- Set_Queues --
------------------------------------------------------------------------
-- Informs of TCP queues available for firewalled searching
procedure Set_Queues (
This : access Object;
Queues : in Packet.Queue.Address_Queue_Array);
------------------------------------------------------------------------
-- Set_Start_Nodes --
------------------------------------------------------------------------
-- Informs of possible start servers (known alive hubs)
-- Receives an array of addresses
procedure Set_Start_Nodes (This : access Object; Nodes : Ustring_Array);
------------------------------------------------------------------------
-- Start --
------------------------------------------------------------------------
-- Sets up the searcher
procedure Start (
This : access Object;
Sender : in G2.Packet.Queue.Object_Access;
Transceiver : in G2.Transceiver.Object_Access);
------------------------------------------------------------------------
-- Shutdown --
------------------------------------------------------------------------
procedure Shutdown (This : in out Object);
-- Debug
procedure Debug_Test (This : in out Object);
private
use type Calendar.Time;
subtype Query_Key is String (1 .. 4); -- 32 bits of key
Null_Key : constant Query_Key := " ";
Guid_Not_Found : exception;
-- Data about known hubs
type Node_Type is record
Address : Ustring;
Scheduled : Boolean := false; -- Says if a hub has a scheduled query
Next_QEvent : Calendar.Time := Past_aeons; -- Time for the next query event
Last_access : Calendar.Time := Past_aeons; -- Last time it has been sent a msg
Last_QA : Calendar.Time := Past_aeons; -- Last QA received
Key : Query_Key := Null_Key;
Key_Time : Calendar.Time := Past_aeons; -- Time at which we got the query key for this host.
Leaves : Natural := 0;
Alive : Boolean := false; -- True when we got some QA from it.
end record;
type Node_Access is access all Node_Type;
------------------------------------------------------------------------
-- Create_Node --
------------------------------------------------------------------------
function Create_Node (
Address : in String;
Last_Access : Calendar.Time := Past_Aeons;
Last_QA : Calendar.Time := Past_Aeons;
Key : Query_key := Null_Key) return Node_Type;
------------------------------------------------------------------------
-- Is_Dropable --
------------------------------------------------------------------------
function Is_Dropable (Node : access Node_Type) return Boolean;
-- Data kept by every search about the queried hubs
type Searched_Node is record
Last_Reply : Calendar.Time := Past_Aeons; -- Last time the hub has answered the srch
end record;
-- List to be used by a single search; not to be confused with the global Search_List
-- which refers to searches and not hubs.
-- Indexed by address
package Searched_List is new Charles.Maps.Sorted.Strings.Unbounded (
Searched_Node, "<", "=");
-- Empty;
Null_Searched_List : Searched_List.Container_Type;
-- G2 queries
type G2_Search is record
Hub_accesses : Natural := 0;
Leaf_accesses : Natural := 0;
Priority : Searches.Priorities;
Priority_delta : Natural; -- Computed from priority [and hits]
Search : Searches.Search_Id; -- Id of the search
Payload : Searches.Payload_Access;
Guid : Guid_String; -- Stored as String
Paused : Boolean := false;
Searched_nodes : Searched_List.Container_Type; -- Hubs already searched.
end record;
type G2_Search_Access is access all G2_Search;
-- Collections to be managed
-- Running searches, indexed by next priority
package Search_List is new Charles.Multimaps.Sorted.Unbounded (
Natural, G2_Search_Access, "<", "=");
-- Running searches, indexed by guid
package Guid_List is new Charles.Maps.Sorted.Strings.Unbounded (
G2_Search_Access, "<", "=");
-- Known hubs, indexed by address:port
package Hub_List is new Charles.Maps.Sorted.Strings.Unbounded (
Node_Type, "<", "=");
-- Direct access to data:
function Get_Access is new Hub_List.Generic_Element (Node_Access);
-- NO ACCESS TO THE MANAGER SHOULD BE MADE FROM WITHIN THIS PROTECTED OBJECT
-- BECAUSE IT IS ACCESED INDIRECTLY BY THE MANAGER
-- THUS PRODUCING MUTUAL DEADLOCKS
protected type Safe_Object (Parent : access Object) is
procedure Add_New_Hub (Address : in String; Just_Searched : in Boolean := false);
procedure Add_New_Hub (
Address : in String; Just_Searched : in Boolean := false; Hub : out Node_Access);
procedure Create_Search (
Target : in Searches.Search_Id;
Payload : in Adagio.Searches.Payload;
Priority : in Searches.Priorities;
PDelta : in Natural);
procedure Delete_Search (Target : in Searches.Search_Id);
procedure Discount_Hub_Data (Hub : access Node_Type);
procedure Do_QA (Item : in G2.Packet.Queue.Item_Type);
procedure Do_QKA (Item : in G2.Packet.Queue.Item_Type);
-- False if no search could be queried for this hub right now
function Exists_Search_For (Hub : in Node_Access) return Boolean;
function Get_Custom_Info (Target : in Searches.Search_Id) return String;
function Get_Hubs return Natural;
-- Rotates through neighbors:
procedure Get_Next_Queue (Queue : out Packet.Queue.Address_Queue);
function Get_Tracked_Hubs return Natural;
function Get_Id_From_Guid (Gu : in Guid_String) return Searches.Search_Id;
-- Says the index that should apply if it were new:
function Get_Index_For (Srch : in G2_Search_Access) return Natural;
function Get_Leaves return Natural;
procedure Http_Report (Data : out Data_Set);
function Is_Neighbor (Address : in String) return Boolean;
function Must_Search return Boolean; -- True if searches enqueued
procedure Pause_Search (Target : in Searches.Search_Id; Paused : in Boolean);
procedure Perform_Searches_Rollback; -- Moves all indexes back
-- The hubs are only dropped if there are running searches.
procedure Process_Drop_Event (Address : in String);
procedure Process_Query_Event (Address : in String);
-- Creates events for querying and checking if alive:
procedure Program_Node_Query (
Hub : access Node_Type; For_Time: in Calendar.Time);
procedure Program_Start_Nodes;
procedure Purge;
procedure Query_Hub (Hub : in Node_Access);
-- Gives the search to be sent to a hub, or null if no valid candidate!
-- Updates priority counters
procedure Select_Search_For (Hub : in Node_Access; Srch : out G2_Search_Access);
procedure Send_To_Neighbor (Address : in String; P : in Packet.Object);
procedure Send_To_Queues (P : in Packet.Object);
procedure Set_Priority (
Target : in Searches.Search_Id; Priority : Searches.Priorities; PDelta : Natural);
procedure Set_Queues (New_Queues : in Packet.Queue.Address_Queue_Array);
procedure Set_Start_Nodes (Nodes : in Ustring_Array);
procedure Start; -- Creates first events
private
Hubs : Hub_List.Container_Type;
Searches : Search_List.Container_Type;
Guids : Guid_List.Container_Type;
-- Queues : Packet.Queue.Address_Queue_Array (1 .. Globals.Options.G2_ActiveServers);
-- Queues : Packet.Queue.Address_Queue_Array (1 .. 100);
-- Above : Workaround for a bug in gnat 3.15p.
-- Will fail for more than 100 active servers (insane!)
Queues : Packet.Queue.Address_Queue_Array_Access;
Queue_Index : Positive := 1;
Starters : Hub_List.Container_Type;
Next_Packet : Calendar.Time := Calendar.Clock;
Leaves : Natural := 0;
Alive_Hubs : Natural := 0;
end Safe_Object;
type Object is new Searches.Handler.Object with record
Events : Agpl.Event_Queues.Calendar.Object;
Safe : Safe_Object (Object'Access);
Sender : G2.Packet.Queue.Object_Access;
Transceiver : G2.Transceiver.Object_Access;
Latency : Duration := 0.0;
pragma Atomic (Latency);
end record;
end Adagio.G2.Search;