File : adagio-searches-search.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-upload.ads,v 1.4 2004/01/21 21:05:51 Jano Exp $
with Adagio.Hash_Dictionary;
with Adagio.Trace;
with Sha1;
with Agpl.Magnet;
with Agpl.Strings.Fields;
with Ada.Unchecked_deallocation;
use Ada;
package body Adagio.Searches.Search is
use type Hit_Family.Object_Access;
------------------------------------------------------------------------
-- Add_Hashes --
------------------------------------------------------------------------
-- Add missing indexes to a family who contains a hit
procedure Add_Hash_Indexes (
This : access Object; F : in Hit_Family.Object_Access; H : in Hit.Object'Class)
is
use Hit_Family_Map;
Hashes : Hash_Dictionary.Pair_Array :=
Hash_Dictionary.Get_Contents (Hit.Get_Hashes (H));
------------
-- Exists --
------------
function Exists (Hash : in String) return Boolean is
First, Back : Iterator_Type;
begin
Equal_Range (This.Hits, Hash, First, Back);
while First /= Back loop
if Element (First) = F then
return true;
end if;
First := Succ (First);
end loop;
return false;
end Exists;
begin
pragma Assert (Hit_Family.Contains (F.all, H));
for I in Hashes'Range loop
declare
Index : constant String := Construct_Pair (Hashes (I).Key, Hashes (I).Value);
begin
if not Exists (Index) then
-- Trace.Log ("INSERTING NEW INDEX: " & Index & " for " & Hit.Get_Name (H),
-- Trace.Always);
Insert (This.Hits, Index, F);
end if;
end;
end loop;
end Add_Hash_Indexes;
------------------------------------------------------------------------
-- Add_Hit --
------------------------------------------------------------------------
-- Search in current families.
-- If found add missing hashes if they exist.
-- If not found create new family.
procedure Add_Hit (This : access Object; New_Hit : in Hit.Object'Class) is
use Hit_Family_Map;
In_Some_Family : Boolean := false;
Fams : Hit_Family.Object_Access_Array := Get_Families (This, New_Hit);
begin
for I in Fams'Range loop
if Hit_Family.Contains (Fams (I).all, New_Hit) then
In_Some_Family := true;
-- Trace.Log ("ALREADY KNOWN HIT: " & Hit.Get_Name (New_Hit), Trace.Always);
Add_Hash_Indexes (This, Fams (I), New_Hit);
elsif Hit_Family.Is_Compatible (Fams (I).all, New_Hit) then
In_Some_Family := true;
--Trace.Log ("MERGED COMPATIBLE HIT: " & Hit.Get_Name (New_Hit), Trace.Always);
Hit_Family.Add_Hit (Fams (I).all, New_Hit);
Add_Hash_Indexes (This, Fams (I), New_Hit);
end if;
end loop;
if not In_Some_Family then
-- Create a new family for this hit
declare
Fam : Hit_Family.Object_Access := new Hit_Family.Object;
J : Iterator_Type;
Success : Boolean;
begin
-- Trace.Log ("CREATED NEW HIT: " & Hit.Get_Name (New_Hit), Trace.Always);
Hit_Family.Create (Fam.all, New_Hit);
-- To ids
Insert (This.Ids, Hit_Family.Get_Id (Fam.all), Fam);
-- To indexes
Add_Hash_Indexes (This, Fam, New_Hit);
end;
end if;
end Add_Hit;
------------------------------------------------------------------------
-- Construct_Pair --
------------------------------------------------------------------------
-- Gets a "key" and "value" and returns "key:value"
function Construct_Pair (K, V : in Ustring) return String
is
begin
return S (K) & ":" & S (V);
end Construct_Pair;
------------------------------------------------------------------------
-- Contains --
------------------------------------------------------------------------
-- Says if a hit already is in the search
function Contains (This : access Object; New_Hit : in Hit.Object'Class) return Boolean is
Fams : Hit_Family.Object_Access_Array := Get_Families (This, New_Hit);
begin
for I in Fams'Range loop
if Hit_Family.Contains (Fams (I).all, New_Hit) then
return true;
end if;
end loop;
return false;
end Contains;
------------------------------------------------------------------------
-- Create --
------------------------------------------------------------------------
function Create (
Target : in String;
Priority : in Priorities) return Object_Access
is
use Agpl;
New_search : Object_access;
begin
-- For now, we'll not detect magnets:
if not Agpl.Magnet.Is_Magnet (Target) then
New_search := new Object (Kind => Keywords);
New_search.Words := U (Target);
New_search.Id := From_String (Target);
else
New_Search := new Object (Kind => Sha1_Digest);
declare
Mg : Magnet.Object := Magnet.Create (Target);
Hash_Type : String := Magnet.Get_Hash_Type (Mg);
Hash : String := Magnet.Get_Hash_Value (Mg);
begin
if Hash_Type = "sha1" then
New_Search.Digest_Text := U (Hash);
else
New_Search.Digest_Text :=
U (Agpl.Strings.Fields.Select_Field (Hash, 1, '.'));
end if;
New_Search.Digest := Sha1.From_Base32 (S (New_Search.Digest_Text));
New_Search.Name := U (Magnet.Get_Name (Mg));
New_search.Id := From_String (Get_Target (New_Search));
end;
end if;
New_search.Priority := Priority;
return New_search;
end Create;
------------------------------------------------------------------------
-- Create_From_XML --
------------------------------------------------------------------------
-- Gets a Search Node (formed like the one generated for saving) and creates an Object
function Create_From_XML (Srch : in Xml.Node) return Object_Access is
Res : Object_Access;
begin
if Xml.Get_Attribute (Srch, "kind", Kinds'Image (Keywords)) = Kinds'Image (Keywords)
then
Res := new Object (Kind => Keywords);
Res.Words := U (Xml.Get_Attribute (Srch, "id", "error"));
Res.Id := From_String (S (Res.Words));
else
Res := new Object (Kind => Sha1_Digest);
declare
Hash : String := Xml.Get_Attribute (Srch, "sha1", "error");
begin
Res.Digest := Sha1.From_Base32 (Hash);
Res.Digest_Text := U (Hash);
Res.Name := U (Xml.Get_Attribute (Srch, "name", ""));
Res.Id := From_String (Get_Target (Res));
end;
end if;
Res.Priority := Priorities'Value (Xml.Get_Attribute (Srch, "priority", "error"));
Res.Paused := Boolean'Value (Xml.Get_Attribute (Srch, "paused", "false"));
return Res;
end Create_From_XML;
------------------------------------------------------------------------
-- Destroy --
------------------------------------------------------------------------
-- This will be null after destruction
procedure Destroy (This : in out Object_access) is
procedure Free is new Unchecked_deallocation (Object, Object_Access);
begin
Free (This);
end Destroy;
-----------------------------
-- Determine_Auto_Priority --
-----------------------------
-- Computes priority from hits thresholds
function Determine_Auto_Priority (Hits : in Natural) return Priorities is
begin
if Hits <= Globals.Options.Search_Priorities_Medium_Threshold then
return High;
elsif Hits <= Globals.Options.Search_Priorities_Low_Threshold then
return Medium;
else
return Low;
end if;
end Determine_Auto_Priority;
------------------------------------------------------------------------
-- Finalize --
------------------------------------------------------------------------
procedure Finalize (This : in out Object) is
use Hit_Family_Map;
I : Iterator_Type := First (This.Ids);
Aux : Hit_Family.Object_Access;
begin
while I /= Back (This.Ids) loop
Aux := Element (I);
Hit_Family.Free (Aux);
I := Succ (I);
end loop;
end Finalize;
------------------------------------------------------------------------
-- Get_Families --
------------------------------------------------------------------------
-- Get families compatible with a hit
-- Without duplicate families
-- There can be at most N! families with the same hash and being distinct ones.
-- Hence the fixed array size of candidates.
function Get_Families (This : access Object; H : in Hit.Object'Class)
return Hit_Family.Object_Access_Array
is
Fams : Hit_Family.Object_Access_Array (1 .. 24);
Num : Natural := 0;
use Hit_Family_Map;
First, Back : Iterator_Type;
Hashes : Hash_Dictionary.Pair_Array :=
Hash_Dictionary.Get_Contents (Hit.Get_Hashes (H));
-- Add if not present
procedure Add_Fam (Fam : in Hit_Family.Object_Access) is
begin
for I in 1 .. Num loop
if Fams (I) = Fam then
return;
end if;
end loop;
Num := Num + 1;
Fams (Num) := Fam;
end Add_Fam;
begin
for I in Hashes'Range loop
Equal_Range (This.Hits, Construct_Pair (Hashes (I).Key, Hashes (I).Value), First, Back);
while First /= Back loop
Add_Fam (Element (First));
First := Succ (First);
end loop;
end loop;
return Fams (1 .. Num);
end Get_Families;
------------------------------------------------------------------------
-- Get_Payload --
------------------------------------------------------------------------
-- Returns the searched thing
function Get_Payload (This : in Object_Access) return Payload is
Target : Payload (Kind => This.Kind);
begin
case This.Kind is
when Keywords =>
Target.Words := This.Words;
when Sha1_Digest =>
Target.Digest := This.Digest;
end case;
return Target;
end Get_Payload;
------------------------------------------------------------------------
-- Pause --
------------------------------------------------------------------------
procedure Pause (This : access Object) is
begin
This.Paused := true;
end Pause;
------------------------------------------------------------------------
-- Resume --
------------------------------------------------------------------------
procedure Resume (This : access Object) is
begin
This.Paused := false;
end Resume;
------------------------------------------------------------------------
-- To_XML --
------------------------------------------------------------------------
-- Returns a freshly allocated and created XML node <search/>
-- Caller should deallocate.
function To_Xml (This : access Object; Doc : in Xml.Document) return Xml.Node is
Srch : Xml.Node := Xml.Create_Child (Doc, "search");
begin
Xml.Set_Attribute (Srch, "id", To_String (This.Id));
Xml.Set_Attribute (Srch, "priority", This.Priority'Img);
Xml.Set_Attribute (Srch, "paused", This.Paused'Img);
Xml.Set_Attribute (Srch, "kind", This.Kind'Img);
if This.Kind = Sha1_Digest then
Xml.Set_Attribute (Srch, "sha1", Sha1.To_Base32 (This.Digest));
Xml.Set_Attribute (Srch, "name", S (This.Name));
end if;
return Srch;
end To_Xml;
------------------------------------------------------------------------
-- "=" --
------------------------------------------------------------------------
function "=" (L, R : in Object) return Boolean is
use type Sha1.Digest;
begin
if L.Kind = R.Kind then
case L.Kind is
when Keywords => return L.Words = R.Words;
when SHA1_digest => return L.Digest = R.Digest;
end case;
else
return false;
end if;
end "=";
------------------------------------------------------------------------
-- Get_xxxxxx --
------------------------------------------------------------------------
function Get_Id (This : access Object) return Search_Id is
begin
return This.Id;
end Get_Id;
function Get_Firewalled_Hits (This : access Object) return Natural is
use Hit_Family_Map;
I : Iterator_Type := First (This.Ids);
Num : Natural := 0;
begin
while I /= Back (This.Ids) loop
Num := Num + Hit_Family.Num_Firewalled_Hits (Element (I).all);
I := Succ (I);
end loop;
return Num;
end Get_Firewalled_Hits;
function Get_Hits (This : access Object) return Natural is
use Hit_Family_Map;
I : Iterator_Type := First (This.Ids);
Num : Natural := 0;
begin
while I /= Back (This.Ids) loop
Num := Num + Hit_Family.Num_Hits (Element (I).all);
I := Succ (I);
end loop;
return Num;
end Get_Hits;
function Get_New_Hits (This : access Object) return Natural is
use Hit_Family_Map;
I : Iterator_Type := First (This.Ids);
Num : Natural := 0;
begin
while I /= Back (This.Ids) loop
Num := Num + Hit_Family.Num_New_Hits (Element (I).all);
I := Succ (I);
end loop;
return Num;
end Get_New_Hits;
function Get_Kind (This : access Object) return Kinds is
begin
return This.Kind;
end Get_Kind;
-- Priority Delta that should now apply:
function Get_Priority_Delta (This : access Object) return Natural is
begin
return Priority_values (Get_Effective_Priority (This));
end Get_Priority_Delta;
-- Priority at creation time:
function Get_Priority (This : access Object) return Priorities is
begin
-- Check priority change:
if This.Priority >= Exclusive5m then
if Calendar.Clock - This.Changed >= Priority_Delays (This.Priority) then
This.Priority := Auto;
end if;
end if;
return This.Priority;
end Get_Priority;
-- Priority applied (distinct from the creation priority only if auto):
function Get_Effective_Priority (This : access Object) return Priorities is
Prio : Priorities := Get_Priority (This);
begin
if Prio = Auto then
return Determine_Auto_Priority (Get_Hits (This));
else
return Prio;
end if;
end Get_Effective_Priority;
function Get_Paused (This : access Object) return Boolean is
begin
return This.Paused;
end Get_Paused;
-- Descriptive target description:
function Get_Target (This : access Object) return String is
begin
case This.Kind is
when Keywords => return S (This.Words);
when Sha1_Digest =>
if This.Name /= Null_Ustring then
return S (This.Digest_Text) & " [" & S (This.Name) & "]";
else
return S (This.Digest_Text) & " [Anon.]";
end if;
end case;
end Get_Target;
------------------------------------------------------------------------
-- Set_Expanded --
------------------------------------------------------------------------
procedure Set_Expanded (
This : access Object; Family : in String; Expanded : in Boolean := true)
is
use Hit_Family_Map;
I : Iterator_Type := Find (This.Ids, Family);
begin
Hit_Family.Set_Expanded (Element (I).all, Expanded);
end Set_Expanded;
------------------------------------------------------------------------
-- Set_xxxxxx --
------------------------------------------------------------------------
procedure Set_Priority (This : access Object; Priority : in Priorities) is
begin
This.Changed := Calendar.Clock;
This.Priority := Priority;
end Set_Priority;
------------------------------------------------------------------------
-- Http_Report --
------------------------------------------------------------------------
procedure Http_Report (This : access Object; Data : in out Data_Set) is
use Hit_Family_Map;
I : Iterator_Type := First (This.Ids);
begin
while I /= Back (This.Ids) loop
Hit_Family.Http_Report (Element (I).all, Data);
I := Succ (I);
end loop;
end Http_Report;
end Adagio.Searches.Search;