File : hashtree.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: hashtree.adb,v 1.5 2004/01/21 21:05:43 Jano Exp $
-- Generic computation of trees of hashes.
-- Can be used to implement for example Tiger trees.
with Adagio.Trace;
use Adagio;
with Acf.Types.Base32;
with Interfaces;
with Ada.Numerics.Generic_elementary_functions;
with Ada.Unchecked_deallocation;
package body HashTree is
-- Set to false to avoid extra checks:
Free_check : constant Boolean := false;
------------------------------------------------------------------------
-- Free --
------------------------------------------------------------------------
procedure Free is new Unchecked_deallocation (Node_type, Node_access);
procedure Free is new Unchecked_deallocation (
Node_matrix, Node_matrix_access);
------------------------------------------------------------------------
-- Go_up --
------------------------------------------------------------------------
-- Goes all the way possible up from a node computing hashes.
-- Frees nodes not needed anymore.
-- Stops on odd nodes or on root if data fininished.
procedure Go_up (
This : in out Object;
Node : access Node_type;
Finish : in Boolean := false)
is
N : Node_access := Node_access (Node);
Parent : Node_access;
begin
loop
-- Stopping conditions?
if N.Coords.Row = 1 then
return;
elsif (not Is_even (N.Coords.Col)) and not Finish then
return;
end if;
-- Go ahead!
if Is_even (N.Coords.Col) then
-- Regular pair
Mix_nodes (
This, (N.Coords.Row, N.Coords.Col - 1), N.Coords);
else -- Finishing, nodes without sibling
Promote_node (This, N);
end if;
Parent := Parent_of (This, N);
-- Free if not more needed:
if N.Coords.Row > This.Keep then
if Is_even (N.Coords.Col) then
Free (This.Nodes (
Node_at ((N.Coords.Row, N.Coords.Col - 1))));
end if;
Free (This.Nodes (Node_at (N.Coords)));
end if;
-- Go up!
N := Parent;
end loop;
end Go_up;
---------------
-- Mix_nodes --
---------------
-- Computes the combination of two nodes.
procedure Mix_nodes (This : in out Object; Left, Right : in Coords_type) is
Context : Hash_context;
Up : Node_access := new Node_type;
L : Node_access := Node_at (This, Left);
R : Node_access := Node_at (This, Right);
begin
Up.Coords := Parent_of (Left);
Begin_inner_hash (Context);
-- Root or middle?
if Up.Coords.Row = 1 then
Start_root_hash (Context);
else
Start_intermediate_hash (Context);
end if;
Update_inner_hash (Context, To_byte_array (L.Hash));
Update_inner_hash (Context, To_byte_array (R.Hash));
Up.Hash := End_inner_hash (Context);
This.Nodes (Node_at (Up.Coords)) := Up;
end Mix_nodes;
------------------
-- Promote_node --
------------------
-- Promotes a node which has no sibling to combine with.
procedure Promote_node (This : in out Object; Left : access Node_type) is
Up : Node_access := new Node_type'(Parent_of (left.Coords), Left.Hash);
begin
This.Nodes (Node_at (Up.Coords)) := Up;
end;
------------------------------------------------------------------------
-- Hash_start --
------------------------------------------------------------------------
-- Use these procedures to iteratively build a tree.
procedure Hash_start (
This : in out Object;
Size : in Natural; -- Of the data to hash
Leaf_size : in Natural := Default_leaf_size;
Keep : in Positive := 10)
is
Blocks : Float;
package Funcs is new Ada.Numerics.Generic_elementary_functions (float);
begin
Destroy (This);
This.Leaf_size := Leaf_size;
This.Size := Size;
This.Keep := Keep;
Blocks := Float'Ceiling (Float (Size) / Float (Leaf_size));
Blocks := Float'Max (Blocks, 1.0); -- At least a block
This.Levels := Positive (Float'Ceiling (Funcs.Log (Blocks, 2.0)) + 1.0);
This.Nodes := new Node_matrix (1 .. Pow2 (This.Levels) - 1);
This.Block_remaining := Leaf_size;
This.Actual := new Node_type;
This.Actual.Coords := (Row => This.Levels, Col => 1);
This.Nodes (Node_at (This.Actual.Coords)) := This.Actual;
Begin_inner_hash (This.Context);
Start_leaf_hash (This.Context);
end Hash_start;
------------------------------------------------------------------------
-- Hash_update --
------------------------------------------------------------------------
-- Feed some bytes to the tree under construction.
procedure Hash_update (
This : in out Object; Bytes : in Acf.Types.Byte_array)
is
Remaining : Natural := This.Block_remaining;
Current : Coords_type;
begin
if Bytes'Length = 0 then
return;
end if;
if Bytes'Length > This.Block_remaining then
Hash_update(
This, Bytes (Bytes'First .. Bytes'First + Remaining - 1));
This.Actual.Hash := End_inner_hash (This.Context);
Begin_inner_hash (This.Context);
Start_leaf_hash (This.Context);
This.Block_remaining := This.Leaf_size;
Current := This.Actual.Coords;
-- Go up from the node leaved behind
if Is_even (Current.Col) then
Go_up (This, This.Actual);
-- Actual may not exist after this point!
end if;
This.Actual := new Node_type;
This.Actual.Coords := (Current.Row, Current.Col + 1);
This.Nodes (Node_at (This.Actual.Coords)) := This.Actual;
Hash_update (
This, Bytes (Bytes'First + Remaining .. Bytes'Last));
else
This.Block_remaining := This.Block_remaining - Bytes'Length;
Update_inner_hash (This.Context, Bytes);
end if;
end Hash_update;
------------------------------------------------------------------------
-- Hash_end --
------------------------------------------------------------------------
-- Completes the building of the tree.
procedure Hash_end (This : in out Object) is
begin
-- Complete leaf hashing:
This.Actual.Hash := End_inner_hash (This.Context);
-- Build upper levels:
Go_up (This, This.Actual, Finish => true);
end Hash_end;
------------------------------------------------------------------------
-- Root_hash --
------------------------------------------------------------------------
-- Get the root hash:
function Root_hash (This : in Object) return Hash_type is
begin
return This.Nodes (1).Hash;
end Root_hash;
------------------------------------------------------------------------
-- Hash_as_base32 --
------------------------------------------------------------------------
-- Convert a hash to Base32:
function Hash_as_base32 (Hash : in Hash_type) return String is
begin
return Acf.Types.Base32.To_base32 (To_byte_array (Hash));
end Hash_as_base32;
------------------------------------------------------------------------
-- Get_bytes --
------------------------------------------------------------------------
-- Get the first N levels of tree bytes in breadth first order:
function Get_bytes (This : in Object; Levels : in Positive)
return Byte_array is
Hash_len : Positive := To_byte_array (Root_hash (This))'Length;
Result : Byte_array (1 .. (2 ** Levels - 1) * Hash_len);
Pos : Natural := Result'First;
begin
if Levels > This.Keep then
raise Constraint_error;
end if;
for N in 1 .. Natural'Min (Pow2 (Levels) - 1, This.Nodes'Last) loop
-- May be null if the tree isn't fully balanced:
if This.Nodes (N) /= null then
Result (Pos .. Pos + Hash_len - 1) :=
To_byte_array (This.Nodes (N).Hash);
Pos := Pos + Hash_len;
end if;
end loop;
return Result (1 .. Pos - 1);
end Get_bytes;
------------------------------------------------------------------------
-- Destroy --
------------------------------------------------------------------------
-- Disposes all memory used by a tree.
procedure Destroy (This : in out Object) is
begin
if This.Nodes = Null then
return; -- <-- EARLY EXIT, ALREADY DESTROYED
end if;
-- Free keeped levels
for N in 1 .. Pow2 (Natural'Min (This.Keep, This.Levels)) - 1 loop
Free (This.Nodes (N)); -- Someone may be already null, it's ok.
end loop;
-- Check already discarded nodes
if Free_check then
for N in This.Nodes'Range loop
if This.Nodes (N) /= null then
Trace.Log ("Unfreed node at" & N'Img, Trace.Always);
raise Constraint_error;
end if;
end loop;
end if;
-- Free matrix
Free (This.Nodes);
end Destroy;
------------------------------------------------------------------------
-- Finalize --
------------------------------------------------------------------------
procedure Finalize (This : in out Object) is
begin
Destroy (This);
end Finalize;
------------------------------------------------------------------------
-- Pow2 --
------------------------------------------------------------------------
-- Computes quickly a power of 2
function Pow2 (N : in Natural) return Positive is
use Interfaces;
begin
if N = 0 then
return 1;
else
return Positive (Interfaces.Shift_left (Unsigned_32' (1), N));
end if;
end Pow2;
------------------------------------------------------------------------
-- Is_even --
------------------------------------------------------------------------
-- Says if a number is even:
function Is_even (N : in Natural) return Boolean is
use Interfaces;
begin
return (Unsigned_32 (N) and 1) = 0;
end Is_even;
------------------------------------------------------------------------
-- Navigation functions --
------------------------------------------------------------------------
-- Get the index to a node:
function Node_at (Coords : in Coords_type)
return Positive is
begin
return Pow2 (Coords.Row - 1) + Coords.Col - 1;
end Node_at;
-- Get the node:
function Node_at (This : in Object; Coords : in Coords_type)
return Node_access is
begin
return This.Nodes (Node_at (Coords));
end Node_at;
-- Get parent coordinates:
function Parent_of (Coords : in Coords_type) return Coords_type is
begin
return (
Row => Coords.Row - 1,
Col => (Coords.Col + 1) / 2);
end Parent_of;
-- Get parent node:
function Parent_of (This : in Object; Node : access Node_type)
return Node_access is
begin
return This.Nodes (Node_at (Parent_of (Node.Coords)));
end Parent_of;
-- Get left child coordinates:
function Left_child (Coords : in Coords_type) return Coords_type is
begin
return (
Row => Coords.Row + 1,
Col => Coords.Col * 2 - 1);
end Left_child;
-- Get left child node:
function Left_child (This : in Object; Node : access Node_type)
return Node_access is
begin
return This.Nodes (Node_at (Left_child (Node.Coords)));
end Left_child;
-- Right counterparts
function Right_child (Coords : in Coords_type) return Coords_type is
begin
return (
Row => Coords.Row + 1,
Col => Coords.Col * 2);
end Right_child;
function Right_child (This : in Object; Node : access Node_type)
return Node_access is
begin
return This.Nodes (Node_at (Right_child (Node.Coords)));
end Right_child;
end HashTree;