File : adagio-g2-core.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 $


with Adagio.Chronos;
with Adagio.G2.Listener;
with Adagio.G2.Packet;
with Adagio.G2.Packet.Parsing;
with Adagio.G2.Packet.Queue;
with Adagio.G2.Search;
with Adagio.G2.Transceiver;
with Adagio.Globals;
with Adagio.Globals.Options;
with Adagio.Http.Header;
with Adagio.Http.Header.Parser;
with Adagio.Network;
with Adagio.Searches.Handler;
with Adagio.Server;
with Adagio.Tcp_slot;
with Adagio.User_profile;
with Adagio.Xml;
with Adagio.Xml.Utils;

with Average_queue;
with Circular_stream;

with Agpl.Http.Server.Sort_handler;

with Zlib.Streams;

with Ada.Calendar;   use Ada;
with Ada.Streams;
with System;

with Charles.Maps.Hashed.Strings.Unbounded;
with Charles.Maps.Sorted.Strings.Unbounded;

pragma Elaborate_all (Adagio.Xml.Utils);
pragma Elaborate_all (Average_queue);

package Adagio.G2.Core is

   pragma Elaborate_body;

   -- Some constants for G2

   Network_id:       Constant String:= "Gnutella2";
   Content_type:     Constant String:= "application/x-gnutella2";

   -------------------

   -- Network stuff --

   -------------------


   type Network_type is new Network.Object with private;
   type Network_access is access all Network_type;

   -- Gives the network identifier

   function Id(this: in Network_type) return String;

   -- Connect to that network. Will get servers and connect them as needed.

   procedure Connect(this: in out Network_type);

   -- Disconnect:

   procedure Disconnect(this: in out Network_type);

   -- Says status of the network.

   function Status(this: in Network_type) return Network.Network_status;

   -- Obtain search handler. Can return null if the network is not to be

   -- searched:

   function Get_Search_Handler (This : in Network_type) 
      return Searches.Handler.Object_Access;

   ------------------

   -- Server stuff --

   ------------------


   type Server_type is new Server.Object with private;
   type Server_access is access all Server_type;
   type Server_array is array (Positive range <>) of Server_access;
--   for Server_access'Storage_pool use Debug_pool;


   -- Get a unique id to identify it:

   function Id (this: in Server_type) return String;
   pragma Inline (Id);

   function Describe (this: in Server_type) return String;
   pragma Inline (Describe);

   -- Get network it belongs:

   function Net (this: in Server_type) return String;

   -- Evaluate its goodness to be connected:

   function Rate (this: in Server_type) return Server.Rating;

   -- Prepare everything for a new server connection attempt:

   procedure Prepare_connect (This : in out Server_type);

   -- Establish a connection:

   procedure Connect(this: in out Server_type);

   -- Do the handshaking:

   procedure Handshake(this: in out Server_type);

   -- Disconnect:

   -- If spare is true, this uptime will not be accounted for ratings.

   procedure Disconnect(this: in out Server_type);
   procedure Disconnect2(
      this: in out Server_type; Spare : in Boolean := false);
   -- Disconnects and lowers rating to 1!

   procedure Disconnect_hub(this: in String);

   -- Clear: dispose all resources

   procedure Clear (this : in out Server_type);

   -- Dump:

   procedure Serialize
     (Stream: access Ada.Streams.Root_stream_type'Class; 
      this: in Server_type); 
   for Server_type'Output use Serialize;

   -- True when the server is to be purged:

   function Dropable (this : in Server_type) return Boolean;

   -- True when ready to connect

   function Is_Ready (This : in Server_Type) return Boolean;

   -- Check against connection settings:

   function Reachable (this : in Server_type) return Boolean;

   -- Recover:

   function Restore
     (Stream: access Ada.Streams.Root_stream_type'Class) return Server_type;
   for Server_type'Input use Restore;

   -- Check for data to read:

   procedure Check_pipes  (this : in out Server_type);

   -- Send pending compressed data:

   procedure Send_pending (this : in out Server_type);

   -- Create a new server from a dotted adress:port 

   procedure Create (
      this     : out Server_type; 
      Net      : in  Network_access;
      Address  : in  String; 
      Port     : in  Natural;
      Seen     : in Calendar.Time := Calendar.Clock);

   -- Compare servers by its id:

   function Equal (L, R : Server_Access) return Boolean;
   pragma Inline (Equal);


   ------------------------------------------------------------------------

   -- Add_hub                                                            --

   ------------------------------------------------------------------------

   -- Creates a hub and adds it to the cache, if possible

   procedure Add_hub (
      Address : in String; Port : in Natural; Score : in Float := 1000000.0);

   ------------------------------------------------------------------------

   -- Send                                                               --

   ------------------------------------------------------------------------

   -- Send a packet to a server

   procedure Send (
      this           : in     Server_access;
      P              : in     Packet.Object;
      In_response_to : in     Packet.Object := Packet.Null_packet);

   ------------------------------------------------------------------------

   -- Finalize                                                           --

   ------------------------------------------------------------------------

   procedure Initialize (this : in out Server_type);
   procedure Adjust     (this : in out Server_type);
   procedure Finalize   (this : in out Server_type);

   ------------------------------------------------------------------------

   -- Add_score                                                          --

   ------------------------------------------------------------------------

   -- Adds score to a server ensuring no overflow

   procedure Add_score (This : in out Server_type; Score : in Server.Rating);

   ------------------

   -- Surveillance --

   ------------------


   -- Monitors that we are really connected.

   task type Connector_type is
      entry Start(this: in Network_access);
   end Connector_type;
   type Connector_access is access all Connector_type;

   -- Polls data from servers:

   task type Polling_type is
      pragma Storage_size (1024 * 1024);
      entry Start(this: in Network_access);
   end Polling_type;
   type Polling_access is access all Polling_type;

   -- Maintenance on servers: keep-alive, searches:

   procedure Maintenance (This : Server_access);

   ----------------

   -- Dispatcher --

   ----------------

   procedure Dispatcher (Net : access Network_type);

   ------------------------------------------------------------------------

   -- Sender                                                             --

   ------------------------------------------------------------------------

   -- Manages pending packets for the server

   procedure Sender (This : access Server_type);
   -- Manages pending outbound udp packets

   task type Sender_udp is
      Pragma Storage_size (64000);
      entry Start (Network : in Network_access);
   end Sender_udp;
   type Sender_udp_access is access all Sender_udp;


   ------------------------

   -- Processing packets --

   ------------------------

   -- Source will be null for UDP packets

   procedure Process_packet (
      Net    : in Network_access; 
      Source : in Server_access;
      Item   : in Packet.Queue.Item_type);

   ----------------------

   -- Creating packets --

   ----------------------

   -- Create a LNI packet with info about us, in respect to the given server.

   function Create_LNI (
      Net         : in Network_access; 
      Destination : in Server_access) return Packet.Object;

   -- Create a /UPROD/XML packet with gprofile.xsd conformat payload.

   function Create_UPROD return Packet.Object;

   -- Create a KHL packet

   function Create_KHL (Net : in Network_access) return Packet.Object;

   type Server_report_record is record
      Uptime : Natural;
      Status : Ustring;
      Id     : Ustring;
   end record;

   type Report_array is array (Positive range <>) of Server_report_record;

   ------------

   -- Report --

   ------------

   function Report (Net : Network_type) return Report_array;

   -- Helper

   function Available_Socket (
      This : access Ada.Streams.Root_stream_type'class) return Natural;
   pragma Inline (Available_socket);

   --------------------

   -- Connected hubs --

   --------------------

   function Connected_hubs return Natural;

   ------------------------------------------------------------------------

   -- Hubs_http_handler                                                  --

   ------------------------------------------------------------------------

   procedure Hubs_http_handler (
      Data : out Agpl.Http.Server.Sort_Handler.Data_set);

private

   use type Ada.Streams.Stream_element_count;
   use type Ada.Streams.Stream_element_offset;

   Protocol_descr : constant Ustring := U ("G2 TCP");

   -- Helper

   function Get_num is new Xml.Get_numeric_attribute_from_path(Natural);

   -- Helper for availables:

   function Available_cstream (
      This : access Ada.Streams.Root_stream_type'class) return Natural;
   pragma Inline (Available_cstream);

   ---------------------

   -- Connection slot --

   ---------------------

   type Server_status is (
      Disconnected, Disconnecting, Connecting, Handshaking, Connected);

   type G2_tcp_slot is new Tcp_slot.Object with record
      Index         : Natural := 0; -- Should not be modified.

      Outbound      : aliased G2.Packet.Queue.Object; 
      -- Queue for outbound messages.

      -- Aliased in queries (process_packet and local_query packages)

      Head          : Http.Header.Set; -- Headers for connection

      -- Response from server

      Http_parser   : Http.Header.Parser.Object (
         Ada.Streams.Stream_element_offset (Globals.Options.G2_MaxHeaders));
      Packet_parser : G2.Packet.Parsing.Object; -- For pipes checking.

      
      -- Deflate related:

      Deflate       : Boolean := false;
      -- Compressed inbound/outbound stream: go to the circular streams:

      ZStream_in    : aliased Zlib.Streams.Stream_type;
      ZStream_out   : aliased Zlib.Streams.Stream_type;
      -- Circular stream: data pendig to be sent/read:

      CStream_in    : aliased Circular_stream.Stream_type (
         Size => Ada.Streams.Stream_element_count (
            Packet.Max_packet_size * 4));
      CStream_out   : aliased Circular_stream.Stream_type (
         Size => Ada.Streams.Stream_element_count (
            Packet.Max_packet_size * 2));
      -- Buffer for outbound pending data to be written:

      OBuffer       : Ada.Streams.Stream_element_array (1 .. 1024);
      OBuffer_used  : Boolean := false;
      OLast         : Ada.Streams.Stream_element_offset;
      -- Automatic flushing of pending zdata

      ZCron         : Adagio.Chronos.Object; -- To flush streams every 5 sec.

      ZFlushed      : Boolean := true;
      ZCreated      : Boolean := false; -- Says if the ZStreams have been set.


      -- Temporary data from the server:

      User_agent    : Ustring;
   end record;
   type G2_tcp_slot_access is access all G2_tcp_slot;
   type Pool_slot is limited record
      Slot        : aliased G2_tcp_slot;
      Server      : Server_access;    -- The server!

      Status      : Server_status;    -- Server status

      In_use      : Boolean := false; -- Internal mark of valid

   end record;
   type Slot_access is access all Pool_slot;
   type Slot_array is array (Positive range <>) of Pool_slot;

   Try_servers : Natural renames Globals.Options.G2_TryServers;
   subtype Try_range is Positive range 1 .. Try_servers;

   ------------------

   -- Servers pool --

   ------------------


   -- Some related exceptions

   Storage_exhausted : Exception;

   protected type Server_pool is
      pragma Priority (System.Priority'Last);
      -- Add a server:

      -- Initially status is set to connecting

      procedure Add (this : in Server_access);

      -- Get a server by Id.

      procedure Get (
         Id     : in  String; 
         Status : in  Server_status;
         Server : out Server_access);
      procedure Get (
         Id     : in  UString; 
         Status : in  Server_status;
         Server : out Server_access);

      -- Get next server:

      -- Will return null if no more:

      procedure Get_next (Server : in out Server_access);

      -- Get first server:

      -- Will return null if no more:

      procedure Get_first (Server : out Server_access);

      -- Get newest connected server:

      procedure Get_newest (Server : out Server_access);

      -- Get a connected server by Id or null if not found:

      function Get (Id : in UString; Status : in Server_status) 
         return Server_access;

      -- Get all servers in a given status as array

      function Get_array (Status : in Server_status) return Server_array;

      -- Get all queues of connected servers but one (optional)

      function Get_queues (But : in Server_access := null) return
         Packet.Queue.Object_array;

      -- As previous but with addresses too (includes port!):

      function Get_Queues_And_Addresses (But : in Server_Access := null)
         return Packet.Queue.Address_Queue_Array;

      -- Count valid servers in any active (not disconnected) status:

      function Active_count return Natural;

      -- Count used slots:

      function Count return Natural;

      -- Count valid servers in a given status:

      function Status_count (Status : in Server_status) return Natural;

      -- Remove a server. Only owner allowed. Must be checked out

      procedure Remove (Server : in out Server_access);
      pragma Inline (Remove);

      -- Disconnect all servers, without pity, regardeless of checking!

      procedure Disconnect_all;

      -- Read status:

      function Status (Server : in Server_access) return Server_status;
      pragma Inline (Status);

      -- Set status:

      procedure Set_status (
         Server : in Server_access; 
         Status : in Server_status);
      pragma Inline (Set_status);

      -- Get an array of readable addresses of connected neighbours:

      function Address_list return Ustring_array;

      -- Get a report of all servers:

      function Report return Report_array;

   private

      -- Data:

      Slots : Slot_array (Try_range);
   end Server_pool;
   type Server_pool_access is access all Server_pool;

   -------------------

   -- Network stuff --

   -------------------


   package Cluster_list is new
      Charles.Maps.Sorted.Strings.Unbounded (Server_access, "<", Equal);

   type Network_type is new Adagio.Network.Object with 
      record
         Status      :  Network.Network_status := Network.Disconnected;
         Connector   :  Connector_access;          -- Task which connects us.

         Polling     :  Polling_access;            -- Get data from servers.


         Servers     :  Server_pool;               -- Servers for the network.


         Port        :  Natural:= 4610;            -- Port for this instance


         Inbound     :  aliased Packet.Queue.Object;       
         Outbound    :  aliased Packet.Queue.Object;       
                                                   -- Queues for G2 packets


         Listener    :  G2.Listener.Object;        -- Listener for incomings.

         Send_udp    :  Sender_udp_access;         -- Outbound packets.


         Transceiver :  G2.Transceiver.Object_access;     
                                                   -- Semi-reliable yaddayadda


         Searcher    : G2.Search.Object_access; 
            -- Create only if downloading enabled

      end record;

   type Stream_access is access all Ada.Streams.Root_stream_type'Class;

   -- Auxiliaries for average uptime queue:

   function Average (Left : in Duration; Right : in Integer) return float;
   pragma Inline (Average);

   package Average_uptime is new Average_queue (Duration, "+", Average);

   ------------------

   -- Server stuff --

   ------------------

   type QRT_status_type is (Not_sent, Sending, Sent);
   type Connection_stages is (
      Starting, 
      Connecting, 
      Handshake_preparing, 
      Handshake_sending_first, 
      Handshake_receiving,
      Handshake_sending_last);

   type Server_type is new Adagio.Server.Object with record
      Slot             : G2_tcp_slot_access;       -- Connection data.

      pragma Atomic (Slot);

      Network          : Network_access;           -- Back reference.


      Address          : Ustring;                  -- Name/ip

      Port             : Natural;                  -- Port

      Local_port       : Natural;                  -- Local listening port


      Connection_stage : Connection_stages := Starting;
      Connection_start : Calendar.Time;            -- Connection start

      Handshake_start  : Calendar.Time;            -- Handshake  start

      Failures         : Natural:= 0;              -- Connection failures

      Successes        : Natural:= 0;              -- Connection successes

      Last_try_connect : Calendar.Time := Past_aeons; -- Try to connect

      Last_try         : Calendar.Time := Past_aeons; -- Updated on disconnect


      Is_root          : Boolean := false;         -- Non-discardable.


      Last_packet_time : Calendar.Time;            -- For keep-alive.

      Last_ping_time   : Calendar.Time;            -- To not flood.

      Last_update      : Calendar.Time := 
         Calendar.Time_of (1976, 9, 6);            -- LNI sends

      Last_seen        : Calendar.Time := Calendar.Clock;            
                                                   -- Last succesful com.

      Delayed_send     : Calendar.Time := Past_aeons;
      Last_delay       : Duration := 0.75;
                                                   -- All tcp packets will

                                                   -- be delayed until this

                                                   -- time.


      Max_leaves       : Natural := 0;             -- Leaves info

      Num_leaves       : Natural := 0;

      Uptimes          : Average_uptime.Object (5);  -- Average uptimes

      Score            : Server.Rating := 300.0;     -- Goodness

      pragma Atomic (Score);

      User_profile     : Adagio.User_profile.Object; -- User profile

      Profile_requested: Boolean := false;

      QRT_timestamp    : Calendar.Time := Past_aeons;
      Checked_QRP      : Calendar.Time := Past_aeons;
      QRT_reset        : Boolean := false;
      QRT_status       : QRT_status_type := Not_sent;
      QRT_packets      : Natural;
      QRT_packets_sent : Natural;

      Apt_For_Search   : Boolean := false; -- 15 seconds before sending searches to it


      Packets_in       : Natural := 0; -- Sent and received packets

      Packets_out      : Natural := 0;
   end record;
   
   ----------------------

   -- Network instance --

   ----------------------

   The_network: G2.Core.Network_access;

end Adagio.G2.Core;