File : adagio-g2-browse_peer.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-browse_peer.adb,v 1.3 2004/01/21 21:05:25 Jano Exp $
with Adagio.Convert;
with Adagio.File;
with Adagio.G2.Core;
with Adagio.G2.Local_query;
with Adagio.G2.Packet;
with Adagio.Globals.Options;
with Adagio.GUID;
with Adagio.Library;
with Adagio.Memory_stream_constrained;
with Adagio.Misc;
with Adagio.Trace;
with Adagio.Unicode;
with Adagio.Zutil;
with Dynamic_vector;
with Ada.Calendar;
use Ada;
package body Adagio.G2.Browse_peer is
use type Packet.Object;
use Element_vector;
Browse_timeout : Duration := 300.0;
Browse_content_type : constant String := "application/x-gnutella2";
Children_per_hit : constant Natural := 32;
------------------------------------------------------------------------
-- Create --
------------------------------------------------------------------------
-- Creation takes a connected socket and a header object with the
-- request already read, so our response is due.
function Create (From : in Socket.Object; Request : in Http.Header.Set)
return Object_access is
Peer : Object_access;
begin
-- Check content-type
if not Misc.Contains (Misc.To_lower (
Http.Header.Get (Request, "Accept")), Browse_content_type)
then
raise Unknown_protocol;
end if;
-- Creation
Peer := new Object;
-- Check deflate
if Misc.Contains (Misc.To_lower (
Http.Header.Get (Request, "Accept-Encoding")), "deflate")
then
Peer.Deflate := true; -- Change to true when we do deflating.
end if;
Peer.Socket := From;
Peer.Link := Socket.Stream (From);
if not Globals.Options.Library_AllowBrowse then
Peer.Status := Rejecting;
end if;
return Peer;
end Create;
------------------------------------------------------------------------
-- Id --
------------------------------------------------------------------------
-- Unique id
function Id (This : in Object) return String is
begin
return "BROWSE/" &
Socket.Image (Socket.Get_peer_name (This.Socket).Addr);
end Id;
------------------------------------------------------------------------
-- Process --
------------------------------------------------------------------------
-- Its chance to do something.
procedure Process (
This : in out Object;
Context : in out Connect.Peer.Context_type) is
use Calendar;
begin
Context.Sleep := 0.1;
-- Check for timeout
if Chronos.Elapsed (This.Timeout) > Browse_timeout then
Trace.Log ("Browse timeout for " & Id (This));
Finalize (This);
Context.Is_done := true;
return;
end if;
-- Check for closing:
if not Socket.Is_alive (This.Socket) then
Trace.Log ("G2 browse connection ended by remote party.");
Finalize (This);
Context.Is_done := true;
return;
end if;
-- Dispatch according to state:
case This.Status is
when Handshaking =>
Handshake (This, Context);
when Rejecting =>
Reject (This, Context);
end case;
end Process;
------------------------------------------------------------------------
-- Finalize --
------------------------------------------------------------------------
-- Release all resources.
procedure Finalize (This : in out Object) is
begin
Socket.Close (This.Socket);
Adagio.Streams.Free (This.ZBuffer);
end Finalize;
------------------------------------------------------------------------
-- Handshake --
------------------------------------------------------------------------
-- Do the handshaking
procedure Handshake (
This : in out Object;
Context : in out Connect.Peer.Context_type)
is
-- Build the response
procedure Stage_two is
use Memory_stream_constrained;
use type File.Object;
use type Packet.Object;
use Library.File_list;
M : aliased Memory_stream_constrained.Stream_type;
P, H : Packet.Object;
procedure Add_packet (P : in Packet.Object) is
begin
if P = Packet.Null_packet then
return;
end if;
Create (M, This.Buffer'Address, This.Buffer'Length);
Packet.Write (M'access, P);
for N in 1 .. Index (M) loop
Append (This.Data, This.Buffer (N));
end loop;
end Add_packet;
C : Chronos.Object;
Num_children : Natural := 0;
begin
-- UPROD
if not This.Uprod_sent then
P := Core.Create_uprod;
Add_packet (P);
This.Uprod_sent := true;
Library.Object.Get_all_files (This.Files);
This.Curr_file := First (This.Files);
end if;
-- HITS
if This.Curr_file /= Back (This.Files) then
P := Local_query.Create_simple_hit_skeleton;
else
P := Packet.Null_packet;
end if;
while This.Curr_file /= Back (This.Files) loop
-- New QH
if Num_children = Children_per_hit then
Add_packet (P);
P := Local_query.Create_simple_hit_skeleton;
Num_children := 0;
end if;
-- New H
-- Trace.Log ("Browse: Adding file " & File.Path (
-- Element (This.Curr_file)));
Local_query.Create_hit_child (
Element (This.Curr_file), Packet.Big_endian (P), H);
Packet.Add_child (P, H);
Num_children := Num_children + 1;
-- Next file
This.Curr_file := Succ (This.Curr_file);
-- Time preempt
if Chronos.Elapsed (C) >= 1.0 and then
This.Curr_file /= Back (This.Files)
then
Add_packet (P);
return; -- Early exit if too much time used creating payload.
end if;
end loop;
Add_packet (P);
-- Deflation?
if This.Deflate then
This.ZBuffer := new Ada.Streams.Stream_element_array (
1 ..
Ada.Streams.Stream_element_offset (Last (This.Data)) + 1024);
Zutil.Deflate (
Ada.Streams.Stream_element_array (
This.Data.Vector (1 .. Last (This.Data))),
This.ZBuffer.all,
This.Last);
Trace.Log ("G2.Browse_peer: Payload ready; Size (deflated): " &
Convert.To_size (Natural (This.Last)));
else
Trace.Log ("G2.Browse_peer: Payload ready; Size: " &
Convert.To_size (Last (This.Data)));
end if;
This.Handshake_stage := Three;
end Stage_two;
-- Send the reply headers
procedure Stage_three is
Response : Http.Header.Set;
begin
Http.Header.Set_response (Response, "HTTP/1.1 200 OK");
Http.Header.Add (Response, "Content-Type", Browse_content_type);
Http.Header.Add (Response, "Server", User_agent);
Http.Header.Add (Response, "Connection", "close");
Http.Header.Add (Response, "Content-Length",
Misc.To_string (Last (This.Data)));
if This.Deflate then
Http.Header.Add (Response, "Content-Encoding", "deflate");
end if;
begin
Http.Header.Write (
Response,
This.Link.all,
Send_response => true,
Send_crlf => true);
Trace.Log ("G2.Browse_peer.Stage_three [Sent]: " &
Http.Header.Write (Response));
This.Handshake_stage := Four;
exception
when E : Socket.Socket_error =>
case Socket.Get_error (E) is
when Socket.Operation_would_block =>
Trace.Log ("G2.Browse_peer.Handshaking (Three): " &
"Headers delayed, link full", Trace.Warning);
when others =>
raise;
end case;
when others =>
raise;
end;
end Stage_three;
procedure Stage_four is
begin
if This.Deflate then
while This.Pos <= Natural (This.Last) loop
begin
Ada.Streams.Stream_element'Write (
This.Link, This.ZBuffer (
Ada.Streams.Stream_element_offset (This.Pos)));
This.Pos := This.Pos + 1;
exception
when E : Socket.Socket_error =>
case Socket.Get_error (E) is
when Socket.Operation_would_block =>
return;
when others =>
raise;
end case;
end;
end loop;
else
while This.Pos <= Last (This.Data) loop
begin
Ada.Streams.Stream_element'Write (
This.Link, This.Data.Vector (This.Pos));
This.Pos := This.Pos + 1;
exception
when E : Socket.Socket_error =>
case Socket.Get_error (E) is
when Socket.Operation_would_block =>
return;
when others =>
raise;
end case;
end;
end loop;
end if;
Socket.Close (This.Socket);
Context.Is_done := true;
end Stage_four;
begin
case This.Handshake_stage is
when One =>
raise Unimplemented;
when Two =>
Stage_two;
when Three =>
Stage_three;
when Four =>
Stage_four;
end case;
end Handshake;
------------------------------------------------------------------------
-- Reject --
------------------------------------------------------------------------
-- Do the rejections
procedure Reject (
This : in out Object;
Context : in out Connect.Peer.Context_type)
is
Response : Http.Header.Set;
begin
Http.Header.Set_response (Response, "HTTP/1.1 404 Browse disabled");
begin
Http.Header.Write (
Response,
This.Link.all,
Send_response => true,
Send_crlf => true);
Socket.Close (This.Socket);
Context.Is_done := true;
Finalize (This);
return;
exception
when E : Socket.Socket_error =>
case Socket.Get_error (E) is
when Socket.Operation_would_block =>
Trace.Log ("G2.Browse_peer.Rejecting: " &
"Headers delayed, link full", Trace.Warning);
when others =>
raise;
end case;
when others =>
raise;
end;
end Reject;
end Adagio.G2.Browse_peer;