File : adagio-searches-manager.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.Globals;
with Adagio.Misc;
with Adagio.Network;
with Adagio.Searches.Search;
with Adagio.Trace;
with Adagio.Xml;
with Strings.Utils;
with Agpl.Magnet;
with Agpl.Safe_File;
with Agpl.Strings;
with Charles.Hash_string;
with Charles.Maps.Hashed.Strings.Unbounded;
with Ada.Streams.Stream_IO;
package body Adagio.Searches.Manager is
use type Searches.Search.Object;
Save_File : constant String := "searches.xml";
function Same_Search (L, R : Searches.Search.Object_Access) return Boolean
is
begin
return L.all = R.all;
end Same_Search;
package Search_list is new Charles.Maps.Hashed.Strings.Unbounded (
Searches.Search.Object_Access,
Charles.Hash_string,
"=",
Same_Search);
-- Indexed by Search_Id, which must be equal to the Target Words/URN
use Search_List;
------------------------------------------------------------------------
-- Object --
------------------------------------------------------------------------
protected Object is
-------------
-- Add_Hit --
-------------
procedure Add_Hit (Id : in Search_Id; H : in Searches.Hit.Object'Class);
--------------
-- Contains --
--------------
-- Says if the search already exists
function Contains (This : in String) return Boolean;
-------------------
-- Create_Search --
-------------------
procedure Create_search (
Target : in String; Priority : in Searches.Priorities; Id : out Search_Id);
-------------------
-- Delete_Search --
-------------------
procedure Delete_Search (Id : in Search_Id);
--------------
-- Get_Hits --
--------------
function Get_Hits (Id : in Search_Id) return Natural;
-----------------
-- Get_Payload --
-----------------
function Get_Payload (Id : in Search_Id) return Payload;
------------------
-- Get_Priority --
------------------
function Get_Priority (Id : in Search_Id) return Priorities;
------------------------
-- Get_Priority_Delta --
------------------------
function Get_Priority_Delta (Id : in Search_Id) return Natural;
----------------
-- Get_Search --
----------------
-- Can raise Search_Not_Found;
function Get_Search (Id : in Search_Id) return Search.Object_Access;
-------------------
-- Insert_Search --
-------------------
-- Inserts a search object in the list.
procedure Insert_Search (Srch: in Search.Object_Access);
------------------
-- Pause_Search --
------------------
procedure Pause_Search (Id : in Search_Id);
-------------------
-- Resume_Search --
-------------------
procedure Resume_Search (Id : in Search_Id);
----------
-- Save --
----------
procedure Save;
------------------
-- Set_Expanded --
------------------
procedure Set_Expanded (
Id : in Search_Id; Family : in String; Expanded : in Boolean := true);
------------------
-- Set_Priority --
------------------
procedure Set_Priority (Id : in Search_Id; Priority : in Priorities);
------------
-- Report --
------------
procedure Report (Data : out Sort_Handler.Data_Set);
------------------------
-- Http_Report_Search --
------------------------
procedure Http_Report_Search (Data : out Sort_Handler.Data_Set);
function Http_Report_Search return Templates_Parser.Translate_Table;
----------------------------
-- Http_Report_Set_Search --
----------------------------
procedure Http_Report_Set_Search (Id : in Search_Id);
private
List : Search_list.Container_type;
Target : Search_Id;
end Object;
protected body Object is
-------------
-- Add_Hit --
-------------
procedure Add_Hit (Id : in Search_Id; H : in Searches.Hit.Object'Class) is
I : Iterator_Type := Find (List, To_String (Id));
Srch : Search.Object_Access;
begin
if I /= Back (List) then
Srch := Element (I);
Search.Add_Hit (Srch, H);
end if;
end Add_Hit;
--------------
-- Contains --
--------------
-- Says if the search already exists
function Contains (This : in String) return Boolean is
begin
return Search_List.Is_In (This, List);
end Contains;
-------------------
-- Create_Search --
-------------------
procedure Create_search (Target : in String; Priority : in Searches.Priorities; Id : out Search_Id)
is
New_Search : Searches.Search.Object_access :=
Searches.Search.Create (Target, Priority);
begin
if not Contains (Target) then
Search_list.Insert (List, To_String (Search.Get_Id (New_Search)), New_search);
Save;
Id := Search.Get_Id (New_Search);
end if;
end Create_search;
-------------------
-- Delete_Search --
-------------------
procedure Delete_Search (Id : in Search_Id) is
I : Iterator_Type := Find (List, To_String (Id));
S : Search.Object_access;
begin
if I /= Back (List) then
S := Element (I);
Delete (List, I);
Search.Destroy (S);
Save;
end if;
end Delete_Search;
--------------
-- Get_Hits --
--------------
function Get_Hits (Id : in Search_Id) return Natural is
begin
return Search.Get_Hits (Get_Search (Id));
end Get_Hits;
-----------------
-- Get_Payload --
-----------------
function Get_Payload (Id : in Search_Id) return Payload is
begin
return Search.Get_Payload (Get_Search (Id));
end Get_Payload;
------------------
-- Get_Priority --
------------------
function Get_Priority (Id : in Search_Id) return Priorities is
begin
return Search.Get_Priority (Get_Search (Id));
end Get_Priority;
------------------------
-- Get_Priority_Delta --
------------------------
function Get_Priority_Delta (Id : in Search_Id) return Natural is
begin
return Search.Get_Priority_Delta (Get_Search (Id));
end Get_Priority_Delta;
----------------
-- Get_Search --
----------------
-- Can raise Search_Not_Found;
function Get_Search (Id : in Search_Id) return Search.Object_Access is
I : Iterator_Type := Find (List, To_String (Id));
begin
if I /= Back (List) then
return Element (I);
else
raise Search_Not_Found;
end if;
end Get_Search;
-------------------
-- Insert_Search --
-------------------
-- Inserts a search object in the list.
procedure Insert_Search (Srch: in Search.Object_Access) is
begin
Search_list.Insert (List, To_String (Search.Get_Id (Srch)), Srch);
end Insert_Search;
------------------
-- Pause_Search --
------------------
procedure Pause_Search (Id : in Search_Id) is
I : Iterator_Type := Find (List, To_String (Id));
begin
if I /= Back (List) then
Search.Pause (Element (I));
Network.List.Set_Search_Paused (Id, true);
Save;
end if;
end Pause_Search;
-------------------
-- Resume_Search --
-------------------
procedure Resume_Search (Id : in Search_Id) is
I : Iterator_Type := Find (List, To_String (Id));
begin
if I /= Back (List) then
Search.Resume (Element (I));
Network.List.Set_Search_Paused (Id, false);
Save;
end if;
end Resume_Search;
----------
-- Save --
----------
procedure Save is
Doc : Xml.Document := Xml.From_String ("<searches/>");
I : Iterator_Type := First (List);
begin
while I /= Back (List) loop
Xml.Add (Doc, Search.To_XML (Element (I), Doc));
I := Succ (I);
end loop;
declare
use Ada.Streams.Stream_IO;
use Agpl;
F : File_Type;
begin
Safe_File.Open (F, Out_File, Name => Globals.Data_Folder & Save_File);
String'Write (Stream (F), Xml.To_String (Doc));
Safe_File.Close (F);
end;
Xml.Delete (Doc);
exception
when E : others =>
Trace.Log ("Searches.Manager.Save: " & Trace.Report (E), Trace.Always);
Xml.Delete (Doc);
end Save;
------------------
-- Set_Expanded --
------------------
procedure Set_Expanded (
Id : in Search_Id; Family : in String; Expanded : in Boolean := true)
is
begin
Search.Set_Expanded (Get_Search (Id), Family, Expanded);
end Set_Expanded;
------------------
-- Set_Priority --
------------------
procedure Set_Priority (Id : in Search_Id; Priority : in Priorities)
is
I : Iterator_Type := Find (List, To_String (Id));
begin
if I /= Back (List) then
Search.Set_Priority (Element (I), Priority);
Network.List.Set_Search_Priority (Id, Priority);
Save;
end if;
end Set_Priority;
------------
-- Report --
------------
procedure Report (Data : out Sort_Handler.Data_Set) is
use Search_List;
use Sort_Handler;
I : Iterator_type := First (List);
begin
while I /= Back (List) loop
declare
Row : Data_Row;
Srch : Searches.Search.Object_access renames Element (I);
use Searches.Search;
begin
-- Target
Append (Row, (U (Get_Target (Srch)), U (Get_Target (Srch))));
-- Hits
Append (Row, (
U (Misc.To_string (Get_Hits (Srch))),
Rpad (Get_Hits (Srch))));
-- New Hits
Append (Row, (
U (Misc.To_string (Get_New_Hits (Srch))),
Rpad (Get_New_Hits (Srch))));
-- Firewalled Hits
Append (Row, (
U (Misc.To_string (Get_Firewalled_Hits (Srch))),
Rpad (Get_Firewalled_Hits (Srch))));
-- Priority
Append (Row, (
U (Priorities'Image (Get_Priority (Srch))),
U (Misc.To_string (Priorities'Pos (Get_Priority (Srch))))));
-- Effective Priority
Append (Row, (
U (Priorities'Image (Get_Effective_Priority (Srch))),
U (Misc.To_string (
Priorities'Pos (Get_Effective_Priority (Srch))))));
-- Paused?
Append (Row, (
U (Boolean'Image (Get_Paused (Srch))),
U (Boolean'Image (Get_Paused (Srch)))));
-- Custom Progress Info
declare
Custom : constant String :=
Network.List.Get_Custom_Info (Get_Id (Srch));
begin
Append (Row, (U (Custom), U(Custom)));
end;
Append (Data, Row);
end;
I := Succ (I);
end loop;
end Report;
------------------------
-- Http_Report_Search --
------------------------
procedure Http_Report_Search (Data : out Sort_Handler.Data_Set) is
Srch : Search.Object_Access := Get_Search (Target);
begin
Search.Http_Report (Srch, Data);
end Http_Report_Search;
function Http_Report_Search return Templates_Parser.Translate_Table is
Srch : Search.Object_Access := Get_Search (Target);
use Templates_Parser;
begin
return (
Assoc ("SINGLE1", Search.Get_Target (Srch)),
Assoc ("SINGLE2", Search.Get_Paused (Srch)));
end Http_Report_Search;
----------------------------
-- Http_Report_Set_Search --
----------------------------
procedure Http_Report_Set_Search (Id : in Search_Id) is
begin
Target := Id;
end Http_Report_Set_Search;
end Object;
------------------------------------------------------------------------
-- Add_Hit --
------------------------------------------------------------------------
procedure Add_Hit (Id : in Search_Id; New_Hit : in Searches.Hit.Object'Class) is
begin
Object.Add_Hit (Id, New_Hit);
end Add_Hit;
------------------------------------------------------------------------
-- Create_search --
------------------------------------------------------------------------
procedure Create_search (
Target : in String;
Priority : in Priorities := Searches.Auto)
is
New_Target : constant String :=
Agpl.Strings.To_Lower (Strings.Utils.Simplify (Target));
Id : Search_Id;
begin
if Agpl.Magnet.Is_Magnet (Target) then
Object.Create_search (Target, Priority, Id);
Network.List.Create_Search (Id);
elsif New_Target = "" then
Trace.Log ("Creating search: dropping incorrect search: " & Target,
Trace.Informative);
elsif Object.Contains (New_Target) then
Trace.Log ("Creating search: dropping duplicated search: " & Target,
Trace.Informative);
else
Object.Create_search (New_Target, Priority, Id);
Network.List.Create_Search (Id);
end if;
end Create_search;
------------------------------------------------------------------------
-- Delete_Search --
------------------------------------------------------------------------
-- No error if non-existant
procedure Delete_Search (Id : in Search_Id) is
begin
Network.List.Delete_Search (Id);
Object.Delete_Search (Id);
end Delete_Search;
------------------------------------------------------------------------
-- Get_Hits --
------------------------------------------------------------------------
-- Number of hits for the search.
function Get_Hits (Id : in Search_Id) return Natural is
begin
return Object.Get_Hits (Id);
end Get_Hits;
------------------------------------------------------------------------
-- Get_Payload --
------------------------------------------------------------------------
-- Returns the search payload
function Get_Payload (Id : in Search_Id) return Payload is
begin
return Object.Get_Payload (Id);
end Get_Payload;
------------------------------------------------------------------------
-- Get_Priority --
------------------------------------------------------------------------
-- May raise Search_Not_Found
function Get_Priority (Id : in Search_Id) return Priorities is
begin
return Object.Get_Priority (Id);
end Get_Priority;
------------------------------------------------------------------------
-- Get_Priority_Delta --
------------------------------------------------------------------------
-- Returns the priority delta for a given search:
-- May raise Search_Not_Found
function Get_Priority_Delta (Id : in Search_Id) return Natural is
begin
return Object.Get_Priority_Delta (Id);
end Get_Priority_Delta;
------------------------------------------------------------------------
-- Pause_Search --
------------------------------------------------------------------------
-- No error if already paused
procedure Pause_Search (Id : in Search_Id) is
begin
Object.Pause_Search (Id);
end Pause_Search;
------------------------------------------------------------------------
-- Restore --
------------------------------------------------------------------------
procedure Restore is
use Ada.Streams.Stream_IO;
use Agpl;
Doc : Xml.Document;
begin
if Safe_File.Exists_For_Reading (Globals.Data_Folder & Save_File) then
Doc := Xml.Parse (Safe_File.Get_Real_Name (Globals.Data_Folder & Save_File));
declare
Searches : Xml.Node_Array := Xml.Get_All (Doc, "search");
New_Search : Search.Object_Access;
begin
for I in Searches'Range loop
New_Search := Search.Create_From_XML (Searches (I));
Object.Insert_Search (New_Search);
Network.List.Create_Search (Search.Get_Id (New_Search));
if Search.Get_Paused (New_Search) then
Network.List.Set_Search_Paused (Search.Get_Id (New_Search), true);
end if;
end loop;
end;
Trace.Log ("Searches restored.");
end if;
end Restore;
------------------------------------------------------------------------
-- Resume_Search --
------------------------------------------------------------------------
-- No error if already running
procedure Resume_Search (Id : in Search_Id) is
begin
Object.Resume_Search (Id);
end Resume_Search;
------------------------------------------------------------------------
-- Set_Expanded --
------------------------------------------------------------------------
procedure Set_Expanded (
Id : in Search_Id; Family : in String; Expanded : in Boolean := true) is
begin
Object.Set_Expanded (Id, Family, Expanded);
end Set_Expanded;
------------------------------------------------------------------------
-- Set_Priority --
------------------------------------------------------------------------
procedure Set_Priority (Id : Search_Id; Priority : in Priorities) is
begin
Object.Set_priority (Id, Priority);
end Set_Priority;
------------------------------------------------------------------------
-- Start --
------------------------------------------------------------------------
-- Start to run the whole thing
procedure Start is
begin
Restore;
end Start;
------------------------------------------------------------------------
-- Http_Report --
------------------------------------------------------------------------
-- Creates the Http dataset.
procedure Http_Report (Data : out Sort_Handler.Data_Set) is
begin
Object.Report (Data);
end Http_Report;
------------------------------------------------------------------------
-- Http_Report_Search --
------------------------------------------------------------------------
-- Http report for the selected search
procedure Http_Report_Search (Data : out Sort_Handler.Data_Set) is
begin
Object.Http_Report_Search (Data);
end Http_Report_Search;
function Http_Report_Search return Templates_Parser.Translate_Table is
use Templates_Parser;
begin
return Object.Http_Report_Search;
end Http_Report_Search;
------------------------------------------------------------------------
-- Http_Report_Set_Search --
------------------------------------------------------------------------
-- Set the search to be reported in subsequent calls
procedure Http_Report_Set_Search (Id : in Search_Id) is
begin
Object.Http_Report_Set_Search (Id);
end Http_Report_Set_Search;
end Adagio.Searches.Manager;