libkeccak_3.0.0_f33be1c8/tests/kat/src/test_vectors.adb

-------------------------------------------------------------------------------
--  Copyright (c) 2019, Daniel King
--  All rights reserved.
--
--  Redistribution and use in source and binary forms, with or without
--  modification, are permitted provided that the following conditions are met:
--      * Redistributions of source code must retain the above copyright
--        notice, this list of conditions and the following disclaimer.
--      * Redistributions in binary form must reproduce the above copyright
--        notice, this list of conditions and the following disclaimer in the
--        documentation and/or other materials provided with the distribution.
--      * The name of the copyright holder may not be used to endorse or promote
--        Products derived from this software without specific prior written
--        permission.
--
--  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
--  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
--  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
--  ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY
--  DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
--  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
--  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
--  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
--  (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
--  THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-------------------------------------------------------------------------------
with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
with Ada.Strings.Maps;       use Ada.Strings.Maps;
with Ada.Strings.Fixed;      use Ada.Strings.Fixed;
with Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with Interfaces; use Interfaces;

with GNAT.Regpat;

package body Test_Vectors is

   use type GNAT.Regpat.Match_Location;

   function Create_List (Value : in Value_Choice) return Value_Choice_Lists.List;

   ----------------
   -- Initialize --
   ----------------

   overriding
   procedure Initialize (Object : in out Value_Choice) is
   begin
      case Object.VType is
         when String_Type =>
            Object.Str := Null_Unbounded_String;

         when Integer_Type =>
            Object.Int := 0;

         when Hex_Array_Type =>
            Object.Hex := null;
      end case;
   end Initialize;

   ------------
   -- Adjust --
   ------------

   overriding
   procedure Adjust (Object : in out Value_Choice) is
   begin
      if Object.VType = Hex_Array_Type and then Object.Hex /= null then
         Object.Hex := new Keccak.Types.Byte_Array'(Object.Hex.all);
      end if;
   end Adjust;

   --------------
   -- Finalize --
   --------------

   overriding
   procedure Finalize (Object : in out Value_Choice) is
      procedure Free is new Ada.Unchecked_Deallocation (Keccak.Types.Byte_Array,
                                                        Byte_Array_Access);

   begin
      if Object.VType = Hex_Array_Type and then Object.Hex /= null then
         Free (Object.Hex);
      end if;
   end Finalize;

   ------------------------------
   -- Hex_String_To_Byte_Array --
   ------------------------------

   function Hex_String_To_Byte_Array (Str : in String) return Byte_Array_Access
   is
      function Char_To_Byte (C : in Character) return Keccak.Types.Byte;

      function Char_To_Byte (C : in Character) return Keccak.Types.Byte
      is
         Byte : Keccak.Types.Byte;
      begin
         if C >= '0' and C <= '9' then
            Byte := Keccak.Types.Byte (Character'Pos (C) - Character'Pos ('0'));

         elsif C >= 'a' and C <= 'f' then
            Byte := Keccak.Types.Byte (16#A# + (Character'Pos (C) - Character'Pos ('a')));

         elsif C >= 'A' and C <= 'F' then
            Byte := Keccak.Types.Byte (16#A# + (Character'Pos (C) - Character'Pos ('A')));

         else
            raise Constraint_Error;

         end if;

         return Byte;
      end Char_To_Byte;

      Byte_Array : Byte_Array_Access;
      I          : Natural := 0;
   begin
      if (Str'Length mod 2 /= 0) then
         raise Constraint_Error;
      end if;

      Byte_Array := new Keccak.Types.Byte_Array (0 .. Str'Length / 2 - 1);

      while I < Str'Length loop
         Byte_Array.all (I / 2) := Shift_Left (Char_To_Byte (Str (Str'First + I)), 4)
                                   or Char_To_Byte (Str (Str'First + I + 1));

         I := I + 2;
      end loop;

      return Byte_Array;

   end Hex_String_To_Byte_Array;

   --------------------------
   -- String_To_Byte_Array --
   --------------------------

   function String_To_Byte_Array (Str : in String) return Byte_Array_Access
   is
      Byte_Array : Byte_Array_Access;

   begin
      Byte_Array := new Keccak.Types.Byte_Array (1 .. Str'Length);

      for I in Natural range 0 .. Str'Length - 1 loop
         Byte_Array (Byte_Array'First + I) :=
           Keccak.Types.Byte (Character'Pos (Str (Str'First + I)));
      end loop;

      return Byte_Array;

   end String_To_Byte_Array;

   --------------------------
   -- Byte_Array_To_String --
   --------------------------

   function Byte_Array_To_String (Data : in Keccak.Types.Byte_Array) return String
   is

      Hex_Characters : constant array (Keccak.Types.Byte range 0 .. 15) of Character :=
         ('0', '1', '2', '3', '4', '5', '6', '7',
          '8', '9', 'A', 'B', 'C', 'D', 'E', 'F');

      Str : String (1 .. Data'Length * 2);
      I   : Natural := 0;
   begin

      while I < Data'Length loop
         Str (I * 2 + 1)     := Hex_Characters (Shift_Right (Data (Data'First + I), 4));
         Str (I * 2 + 2) := Hex_Characters (Data (Data'First + I) mod 16);

         I := I + 1;
      end loop;

      return Str;

   end Byte_Array_To_String;

   -----------------
   -- Create_List --
   -----------------

   function Create_List (Value : in Value_Choice) return Value_Choice_Lists.List is
   begin
      return L : Value_Choice_Lists.List do
         L := Value_Choice_Lists.Empty_List;
         L.Append (Value);
      end return;
   end Create_List;

   ----------
   -- Load --
   ----------

   Pair_Regex       : constant GNAT.Regpat.Pattern_Matcher :=
     GNAT.Regpat.Compile ("^(\w+)\s*=\s*""?([^""]*)""?$");

   Empty_Line_Regex : constant GNAT.Regpat.Pattern_Matcher :=
     GNAT.Regpat.Compile ("^\s*$");

   procedure Load (File_Name    : in     String;
                   Schema       : in     Schema_Maps.Map;
                   Vectors_List :    out Lists.List) is

      File : Ada.Text_IO.File_Type;

      Test_Vector : Test_Vector_Maps.Map := Test_Vector_Maps.Empty_Map;

   begin

      Vectors_List := Lists.Empty_List;

      Ada.Text_IO.Open (File => File,
                        Mode => Ada.Text_IO.In_File,
                        Name => File_Name);

      while not Ada.Text_IO.End_Of_File (File) loop
         declare
            --  Read a line and trim whitespace.
            Line : constant String := Trim (Source => Ada.Text_IO.Get_Line (File),
                                            Left   => To_Set (" " & CR),
                                            Right  => To_Set (" " & CR));
         begin
            Parse_Line (Test_Vector, Vectors_List, Schema, Line);
         end;
      end loop;

      Ada.Text_IO.Close (File);

      Append_Test_Vector (Test_Vector, Vectors_List, Schema);
   end Load;

   ----------------
   -- Parse_Line --
   ----------------

   procedure Parse_Line (Test_Vector  : in out Test_Vector_Maps.Map;
                         Vectors_List : in out Lists.List;
                         Schema       : in     Schema_Maps.Map;
                         Line         : in     String)
   is
      Pair_Match       : GNAT.Regpat.Match_Array (0 .. 2) := (others => GNAT.Regpat.No_Match);
      Empty_Line_Match : GNAT.Regpat.Match_Array (0 .. 0) := (others => GNAT.Regpat.No_Match);

      Key_First : Natural;
      Key_Last  : Natural;
      Key       : Unbounded_String;

      Value_First : Natural;
      Value_Last  : Natural;
      Value       : Unbounded_String;
   begin

      GNAT.Regpat.Match (Pair_Regex,       Line, Pair_Match);
      GNAT.Regpat.Match (Empty_Line_Regex, Line, Empty_Line_Match);

      if Empty_Line_Match (0) /= GNAT.Regpat.No_Match then
         --  Found an empty line. This signals the end of the current test vector entry.

         Append_Test_Vector (Test_Vector, Vectors_List, Schema);

         Test_Vector_Maps.Clear (Test_Vector);

      elsif Pair_Match (0) /= GNAT.Regpat.No_Match then
         Key_First := Pair_Match (1).First;
         Key_Last  := Pair_Match (1).Last;
         Key := To_Unbounded_String (Line (Key_First .. Key_Last));

         if Pair_Match (2) = GNAT.Regpat.No_Match then
            Value_First := Line'First;
            Value_Last  := Line'First - 1;
         else
            Value_First := Pair_Match (2).First;
            Value_Last  := Pair_Match (2).Last;
         end if;
         Value := To_Unbounded_String (Line (Value_First .. Value_Last));

         Add_Test_Vector_Key_Value_Pair (Test_Vector, Vectors_List, Schema, Key, Value);

      end if;
   end Parse_Line;

   ------------------------------------
   -- Add_Test_Vector_Key_Value_Pair --
   ------------------------------------

   procedure Add_Test_Vector_Key_Value_Pair (Test_Vector  : in out Test_Vector_Maps.Map;
                                             Vectors_List : in out Lists.List;
                                             Schema       : in     Schema_Maps.Map;
                                             Key          : in     Unbounded_String;
                                             Value        : in     Unbounded_String)
   is
      procedure Update_List (Key  : in     Unbounded_String;
                             List : in out Value_Choice_Lists.List);

      procedure Update_List (Key    : in     Unbounded_String;
                             List   : in out Value_Choice_Lists.List) is
      begin
         case Schema.Element (Key).VType is
            when String_Type =>
               List.Append
                 (Value_Choice'(Controlled with
                  VType => String_Type,
                  Str   => Value));

            when Integer_Type =>
               List.Append
                 (Value_Choice'(Controlled with
                  VType => Integer_Type,
                  Int   => Integer'Value (To_String (Value))));

            when Hex_Array_Type =>
               List.Append
                 (Value_Choice'(Controlled with
                  VType => Hex_Array_Type,
                  Hex   => Hex_String_To_Byte_Array (To_String (Value))));

         end case;
      end Update_List;

   begin
      if Schema.Contains (Key) then

         --  Some test vector files do not have blank lines separating
         --  each test vector, so if we find a key that we have already
         --  put into the current test vector then we have found the
         --  start of the next test vector.
         if Test_Vector.Contains (Key) and not Schema.Element (Key).Is_List then
            Append_Test_Vector (Test_Vector, Vectors_List, Schema);
         end if;

         if Test_Vector.Contains (Key) then

            Test_Vector.Update_Element (Position => Test_Vector.Find (Key),
                                        Process  => Update_List'Access);

         else
            case Schema.Element (Key).VType is
               when String_Type =>
                  Test_Vector.Insert
                    (Key      => Key,
                     New_Item => Create_List (Value_Choice'(Controlled with
                       VType => String_Type,
                       Str   => Value)));

               when Integer_Type =>
                  Test_Vector.Insert
                    (Key      => Key,
                     New_Item => Create_List (Value_Choice'(Controlled with
                       VType => Integer_Type,
                       Int   => Integer'Value (To_String (Value)))));

               when Hex_Array_Type =>
                  Test_Vector.Insert
                    (Key      => Key,
                     New_Item => Create_List (Value_Choice'(Controlled with
                       VType => Hex_Array_Type,
                       Hex   => Hex_String_To_Byte_Array (To_String (Value)))));

            end case;
         end if;
      else
         raise Schema_Error with "Unknown key";
      end if;
   end Add_Test_Vector_Key_Value_Pair;

   ------------------------
   -- Append_Test_Vector --
   ------------------------

   procedure Append_Test_Vector (Test_Vector  : in out Test_Vector_Maps.Map;
                                 Vectors_List : in out Lists.List;
                                 Schema       : in     Schema_Maps.Map)
   is
   begin
      if not Test_Vector_Maps.Is_Empty (Test_Vector) then

         --  Check if there are any missing required schema values
         for C in Schema.Iterate loop
            if Schema_Maps.Element (C).Required and
              not Test_Vector.Contains (Schema_Maps.Key (C))
            then
               raise Schema_Error with "Missing required key";
            end if;
         end loop;

         Lists.Append (Vectors_List, Test_Vector);
      end if;
   end Append_Test_Vector;

end Test_Vectors;