| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT LIBRARY COMPONENTS -- |
| -- -- |
| -- G N A T . S E C U R E _ H A S H E S -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2009-2014, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
| -- -- |
| -- As a special exception under Section 7 of GPL version 3, you are granted -- |
| -- additional permissions described in the GCC Runtime Library Exception, -- |
| -- version 3.1, as published by the Free Software Foundation. -- |
| -- -- |
| -- You should have received a copy of the GNU General Public License and -- |
| -- a copy of the GCC Runtime Library Exception along with this program; -- |
| -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- |
| -- <http://www.gnu.org/licenses/>. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with System; use System; |
| with Interfaces; use Interfaces; |
| |
| package body GNAT.Secure_Hashes is |
| |
| Hex_Digit : constant array (Stream_Element range 0 .. 15) of Character := |
| "0123456789abcdef"; |
| |
| type Fill_Buffer_Access is |
| access procedure |
| (M : in out Message_State; |
| S : String; |
| First : Natural; |
| Last : out Natural); |
| -- A procedure to transfer data from S, starting at First, into M's block |
| -- buffer until either the block buffer is full or all data from S has been |
| -- consumed. |
| |
| procedure Fill_Buffer_Copy |
| (M : in out Message_State; |
| S : String; |
| First : Natural; |
| Last : out Natural); |
| -- Transfer procedure which just copies data from S to M |
| |
| procedure Fill_Buffer_Swap |
| (M : in out Message_State; |
| S : String; |
| First : Natural; |
| Last : out Natural); |
| -- Transfer procedure which swaps bytes from S when copying into M. S must |
| -- have even length. Note that the swapping is performed considering pairs |
| -- starting at S'First, even if S'First /= First (that is, if |
| -- First = S'First then the first copied byte is always S (S'First + 1), |
| -- and if First = S'First + 1 then the first copied byte is always |
| -- S (S'First). |
| |
| procedure To_String (SEA : Stream_Element_Array; S : out String); |
| -- Return the hexadecimal representation of SEA |
| |
| ---------------------- |
| -- Fill_Buffer_Copy -- |
| ---------------------- |
| |
| procedure Fill_Buffer_Copy |
| (M : in out Message_State; |
| S : String; |
| First : Natural; |
| Last : out Natural) |
| is |
| Buf_String : String (M.Buffer'Range); |
| for Buf_String'Address use M.Buffer'Address; |
| pragma Import (Ada, Buf_String); |
| |
| Length : constant Natural := |
| Natural'Min (M.Block_Length - M.Last, S'Last - First + 1); |
| |
| begin |
| pragma Assert (Length > 0); |
| |
| Buf_String (M.Last + 1 .. M.Last + Length) := |
| S (First .. First + Length - 1); |
| M.Last := M.Last + Length; |
| Last := First + Length - 1; |
| end Fill_Buffer_Copy; |
| |
| ---------------------- |
| -- Fill_Buffer_Swap -- |
| ---------------------- |
| |
| procedure Fill_Buffer_Swap |
| (M : in out Message_State; |
| S : String; |
| First : Natural; |
| Last : out Natural) |
| is |
| pragma Assert (S'Length mod 2 = 0); |
| Length : constant Natural := |
| Natural'Min (M.Block_Length - M.Last, S'Last - First + 1); |
| begin |
| Last := First; |
| while Last - First < Length loop |
| M.Buffer (M.Last + 1 + Last - First) := |
| (if (Last - S'First) mod 2 = 0 |
| then S (Last + 1) |
| else S (Last - 1)); |
| Last := Last + 1; |
| end loop; |
| M.Last := M.Last + Length; |
| Last := First + Length - 1; |
| end Fill_Buffer_Swap; |
| |
| --------------- |
| -- To_String -- |
| --------------- |
| |
| procedure To_String (SEA : Stream_Element_Array; S : out String) is |
| pragma Assert (S'Length = 2 * SEA'Length); |
| begin |
| for J in SEA'Range loop |
| declare |
| S_J : constant Natural := 1 + Natural (J - SEA'First) * 2; |
| begin |
| S (S_J) := Hex_Digit (SEA (J) / 16); |
| S (S_J + 1) := Hex_Digit (SEA (J) mod 16); |
| end; |
| end loop; |
| end To_String; |
| |
| ------- |
| -- H -- |
| ------- |
| |
| package body H is |
| |
| procedure Update |
| (C : in out Context; |
| S : String; |
| Fill_Buffer : Fill_Buffer_Access); |
| -- Internal common routine for all Update procedures |
| |
| procedure Final |
| (C : Context; |
| Hash_Bits : out Ada.Streams.Stream_Element_Array); |
| -- Perform final hashing operations (data padding) and extract the |
| -- (possibly truncated) state of C into Hash_Bits. |
| |
| ------------ |
| -- Digest -- |
| ------------ |
| |
| function Digest (C : Context) return Message_Digest is |
| Hash_Bits : Stream_Element_Array |
| (1 .. Stream_Element_Offset (Hash_Length)); |
| begin |
| Final (C, Hash_Bits); |
| return MD : Message_Digest do |
| To_String (Hash_Bits, MD); |
| end return; |
| end Digest; |
| |
| function Digest (S : String) return Message_Digest is |
| C : Context; |
| begin |
| Update (C, S); |
| return Digest (C); |
| end Digest; |
| |
| function Digest (A : Stream_Element_Array) return Message_Digest is |
| C : Context; |
| begin |
| Update (C, A); |
| return Digest (C); |
| end Digest; |
| |
| function Digest (C : Context) return Binary_Message_Digest is |
| Hash_Bits : Stream_Element_Array |
| (1 .. Stream_Element_Offset (Hash_Length)); |
| begin |
| Final (C, Hash_Bits); |
| return Hash_Bits; |
| end Digest; |
| |
| function Digest (S : String) return Binary_Message_Digest is |
| C : Context; |
| begin |
| Update (C, S); |
| return Digest (C); |
| end Digest; |
| |
| function Digest |
| (A : Stream_Element_Array) return Binary_Message_Digest |
| is |
| C : Context; |
| begin |
| Update (C, A); |
| return Digest (C); |
| end Digest; |
| |
| ----------- |
| -- Final -- |
| ----------- |
| |
| -- Once a complete message has been processed, it is padded with one 1 |
| -- bit followed by enough 0 bits so that the last block is 2 * Word'Size |
| -- bits short of being completed. The last 2 * Word'Size bits are set to |
| -- the message size in bits (excluding padding). |
| |
| procedure Final |
| (C : Context; |
| Hash_Bits : out Stream_Element_Array) |
| is |
| FC : Context := C; |
| |
| Zeroes : Natural; |
| -- Number of 0 bytes in padding |
| |
| Message_Length : Unsigned_64 := FC.M_State.Length; |
| -- Message length in bytes |
| |
| Size_Length : constant Natural := |
| 2 * Hash_State.Word'Size / 8; |
| -- Length in bytes of the size representation |
| |
| begin |
| Zeroes := (Block_Length - 1 - Size_Length - FC.M_State.Last) |
| mod FC.M_State.Block_Length; |
| declare |
| Pad : String (1 .. 1 + Zeroes + Size_Length) := |
| (1 => Character'Val (128), others => ASCII.NUL); |
| |
| Index : Natural; |
| First_Index : Natural; |
| |
| begin |
| First_Index := (if Hash_Bit_Order = Low_Order_First |
| then Pad'Last - Size_Length + 1 |
| else Pad'Last); |
| |
| Index := First_Index; |
| while Message_Length > 0 loop |
| if Index = First_Index then |
| |
| -- Message_Length is in bytes, but we need to store it as |
| -- a bit count). |
| |
| Pad (Index) := Character'Val |
| (Shift_Left (Message_Length and 16#1f#, 3)); |
| Message_Length := Shift_Right (Message_Length, 5); |
| |
| else |
| Pad (Index) := Character'Val (Message_Length and 16#ff#); |
| Message_Length := Shift_Right (Message_Length, 8); |
| end if; |
| |
| Index := Index + |
| (if Hash_Bit_Order = Low_Order_First then 1 else -1); |
| end loop; |
| |
| Update (FC, Pad); |
| end; |
| |
| pragma Assert (FC.M_State.Last = 0); |
| |
| Hash_State.To_Hash (FC.H_State, Hash_Bits); |
| |
| -- HMAC case: hash outer pad |
| |
| if C.KL /= 0 then |
| declare |
| Outer_C : Context; |
| Opad : Stream_Element_Array := |
| (1 .. Stream_Element_Offset (Block_Length) => 16#5c#); |
| |
| begin |
| for J in C.Key'Range loop |
| Opad (J) := Opad (J) xor C.Key (J); |
| end loop; |
| |
| Update (Outer_C, Opad); |
| Update (Outer_C, Hash_Bits); |
| |
| Final (Outer_C, Hash_Bits); |
| end; |
| end if; |
| end Final; |
| |
| -------------------------- |
| -- HMAC_Initial_Context -- |
| -------------------------- |
| |
| function HMAC_Initial_Context (Key : String) return Context is |
| begin |
| if Key'Length = 0 then |
| raise Constraint_Error with "null key"; |
| end if; |
| |
| return C : Context (KL => (if Key'Length <= Key_Length'Last |
| then Key'Length |
| else Stream_Element_Offset (Hash_Length))) |
| do |
| -- Set Key (if longer than block length, first hash it) |
| |
| if C.KL = Key'Length then |
| declare |
| SK : String (1 .. Key'Length); |
| for SK'Address use C.Key'Address; |
| pragma Import (Ada, SK); |
| begin |
| SK := Key; |
| end; |
| |
| else |
| C.Key := Digest (Key); |
| end if; |
| |
| -- Hash inner pad |
| |
| declare |
| Ipad : Stream_Element_Array := |
| (1 .. Stream_Element_Offset (Block_Length) => 16#36#); |
| |
| begin |
| for J in C.Key'Range loop |
| Ipad (J) := Ipad (J) xor C.Key (J); |
| end loop; |
| |
| Update (C, Ipad); |
| end; |
| end return; |
| end HMAC_Initial_Context; |
| |
| ------------ |
| -- Update -- |
| ------------ |
| |
| procedure Update |
| (C : in out Context; |
| S : String; |
| Fill_Buffer : Fill_Buffer_Access) |
| is |
| Last : Natural; |
| |
| begin |
| C.M_State.Length := C.M_State.Length + S'Length; |
| |
| Last := S'First - 1; |
| while Last < S'Last loop |
| Fill_Buffer (C.M_State, S, Last + 1, Last); |
| |
| if C.M_State.Last = Block_Length then |
| Transform (C.H_State, C.M_State); |
| C.M_State.Last := 0; |
| end if; |
| end loop; |
| |
| end Update; |
| |
| ------------ |
| -- Update -- |
| ------------ |
| |
| procedure Update (C : in out Context; Input : String) is |
| begin |
| Update (C, Input, Fill_Buffer_Copy'Access); |
| end Update; |
| |
| ------------ |
| -- Update -- |
| ------------ |
| |
| procedure Update (C : in out Context; Input : Stream_Element_Array) is |
| S : String (1 .. Input'Length); |
| for S'Address use Input'Address; |
| pragma Import (Ada, S); |
| begin |
| Update (C, S, Fill_Buffer_Copy'Access); |
| end Update; |
| |
| ----------------- |
| -- Wide_Update -- |
| ----------------- |
| |
| procedure Wide_Update (C : in out Context; Input : Wide_String) is |
| S : String (1 .. 2 * Input'Length); |
| for S'Address use Input'Address; |
| pragma Import (Ada, S); |
| begin |
| Update |
| (C, S, |
| (if System.Default_Bit_Order /= Low_Order_First |
| then Fill_Buffer_Swap'Access |
| else Fill_Buffer_Copy'Access)); |
| end Wide_Update; |
| |
| ----------------- |
| -- Wide_Digest -- |
| ----------------- |
| |
| function Wide_Digest (W : Wide_String) return Message_Digest is |
| C : Context; |
| begin |
| Wide_Update (C, W); |
| return Digest (C); |
| end Wide_Digest; |
| |
| function Wide_Digest (W : Wide_String) return Binary_Message_Digest is |
| C : Context; |
| begin |
| Wide_Update (C, W); |
| return Digest (C); |
| end Wide_Digest; |
| |
| end H; |
| |
| ------------------------- |
| -- Hash_Function_State -- |
| ------------------------- |
| |
| package body Hash_Function_State is |
| |
| ------------- |
| -- To_Hash -- |
| ------------- |
| |
| procedure To_Hash (H : State; H_Bits : out Stream_Element_Array) is |
| Hash_Words : constant Natural := H'Size / Word'Size; |
| Result : State (1 .. Hash_Words) := |
| H (H'Last - Hash_Words + 1 .. H'Last); |
| |
| R_SEA : Stream_Element_Array (1 .. Result'Size / 8); |
| for R_SEA'Address use Result'Address; |
| pragma Import (Ada, R_SEA); |
| |
| begin |
| if System.Default_Bit_Order /= Hash_Bit_Order then |
| for J in Result'Range loop |
| Swap (Result (J)'Address); |
| end loop; |
| end if; |
| |
| -- Return truncated hash |
| |
| pragma Assert (H_Bits'Length <= R_SEA'Length); |
| H_Bits := R_SEA (R_SEA'First .. R_SEA'First + H_Bits'Length - 1); |
| end To_Hash; |
| |
| end Hash_Function_State; |
| |
| end GNAT.Secure_Hashes; |
