-- SHA256 - Provide an idealized interface to the US Secure Hash Algorithm 256 function.
-- Copyright (C) 2020 Prince Trippy programmer@verisimilitudes.net.

-- This program is free software: you can redistribute it and/or modify it under the terms of the
-- GNU Affero General Public License version 3 as published by the Free Software Foundation

-- 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 Affero General Public License for more details.

-- You should have received a copy of the GNU Affero General Public License along with this program.
-- If not, see <http://www.gnu.org/licenses/>.

pragma Restrictions(No_Recursion, No_Allocators, No_Exceptions, No_Access_Subprograms);

with Interfaces; -- As with SHA-1, I'll not be bothering to write my own rotation function for this.

package body SHA256 is
   -- There's naught particularly special about the Ch and Maj; they're trivial and cause one issue.
   -- The only reason they'd be generic in an implementation is due to the varying sizes for a Word.
   function Ch (A, B, C : in Word) return Word is
   begin
      return (A and B) or (C and not A);
   end Ch;

   function Maj (A, B, C : in Word) return Word is
   begin
      return (A and B) or (A and C) or (B and C);
   end Maj;

   subtype Shift_Amount is Integer range 0 .. 31;

   function Rotate_Right (Value : in Word; Amount : in Shift_Amount) return Word is
   begin
      return Word(Interfaces.Rotate_Right(Interfaces.Unsigned_32(Value), Amount));
   end Rotate_Right;

   function Shift_Right (Value : in Word; Amount : in Shift_Amount) return Word is
   begin
      return Word(Interfaces.Shift_Right(Interfaces.Unsigned_32(Value), Amount));
   end Shift_Right;

   -- The sigma functions are simple, similarly to the Ch and Maj, and perhaps simpler than in Lisp.
   -- I may as well make these generic, this being much easier to do with two than one, unlike Lisp.
   -- There's no good sense in not specifying the rotation values in the generic instantiation here.
   generic
      A, B, C : Shift_Amount;
   function Generic_Big_Sigma (T : in Word) return Word;

   function Generic_Big_Sigma (T : in Word) return Word is
   begin
      return Rotate_Right(T, A) xor Rotate_Right(T, B) xor Rotate_Right(T, C);
   end Generic_Big_Sigma;

   function Big_Sigma_Zero is new Generic_Big_Sigma(A => 2, B => 13, C => 22);
   function Big_Sigma_One  is new Generic_Big_Sigma(A => 6, B => 11, C => 25);

   generic
      A, B, C : Shift_Amount;
   function Generic_Small_Sigma (T : in Word) return Word;

   function Generic_Small_Sigma (T : in Word) return Word is
   begin
      return Rotate_Right(T, A) xor Rotate_Right(T, B) xor Shift_Right(T, C);
   end Generic_Small_Sigma;

   function Small_Sigma_Zero is new Generic_Small_Sigma(A =>  7, B => 18, C =>  3);
   function Small_Sigma_One  is new Generic_Small_Sigma(A => 17, B => 19, C => 10);

   procedure Hash (State : in out Status; Data : in Word_Block) is
      Old : Status := State; -- Surely there's a more convenient way to initialize W, declaratively.
      W   : array (Cycle) of Word := (Data( 1), Data( 2), Data( 3), Data( 4), Data( 5), Data( 6),
                                      Data( 7), Data( 8), Data( 9), Data(10), Data(11), Data(12),
                                      Data(13), Data(14), Data(15), Data(16), others => <>);
      T1, T2 : Word; -- By my knowledge, this is the only way to declare this set of such renamings.
      A : Word renames Old(0); B : Word renames Old(1); C : Word renames Old(2);
      D : Word renames Old(3); E : Word renames Old(4); F : Word renames Old(5);
      G : Word renames Old(6); H : Word renames Old(7);
   begin
      for T in 16 .. Cycle'Last loop
         W(T) := W(T - 7) + W(T - 16) + Small_Sigma_One(W(T - 2)) + Small_Sigma_Zero(W(T - 15));
      end loop;
      for T in Cycle'Range loop
         T1 :=  Ch(E, F, G) + Big_Sigma_One(E) + H + K(T) + W(T);
         T2 := Maj(A, B, C) + Big_Sigma_Zero(A);
         H  := G; G := F; F := E; E := T1 + D;
         D  := C; C := B; B := A; A := T1 + T2;
      end loop;
      for T in State'Range loop -- This example alone makes it clear Status should be an array type.
        State(T) := State(T) + Old(T);
     end loop;
   end Hash;

   -- These following two procedures could warrant a generic procedure, but I'm not going to bother.
   procedure Hash (State : in out Status; Data : in Bit_Block) is
      W : Word_Block;
   begin
      Bits_To_Words(From => Data, To => W);
      Hash(State, W);
   end Hash;

   procedure Hash (State : in out Status; Data : in Octet_Block) is
      W : Word_Block;
   begin
      Octets_To_Words(From => Data, To => W);
      Hash(State, W);
   end Hash;

   generic
      type Unit is mod <>;
      Bits : Positive; -- I should soon eliminate this later through use of the S'Modulus attribute.
      type Unit_Block_Range is range <>;
      type Unit_Block is array (Unit_Block_Range) of Unit;
   procedure Generic_Pad (Primary      : in out Unit_Block;
                          Auxiliary    :    out Unit_Block;
                          Unit_Length  : in     Natural;
                          Overflow     :    out Boolean);

   procedure Generic_Pad (Primary      : in out Unit_Block;
                          Auxiliary    :    out Unit_Block;
                          Unit_Length  : in     Natural;
                          Overflow     :    out Boolean) is
      Final : constant Natural := Natural(Unit_Block'Last); -- This constant warrants a naming here.
      -- It's pleasant I can use Shift_Right here; it's a nicer solution than using mod 2**32 there.
      procedure Write_Length (Data : out Unit_Block) is -- Has this multiplication an overflow risk?
         Truncated : Interfaces.Unsigned_64 := Interfaces.Unsigned_64'Mod(Unit_Length * Bits);
      begin -- The range here was written before the introduction of Final; I may change this later.
         for I in reverse Unit_Block_Range range Data'Last - (Data'Last / 8) .. Data'Last loop
            Data(I)   := Unit'Mod(Truncated);
            Truncated := Interfaces.Shift_Right(Truncated, Bits);
         end loop;
      end Write_Length;
      -- By requiring the length be in terms of the block unit, I reduce all Pad to the binary ease.
      -- Rather than laboriously calculate the unit position of this bit, a constant is always used.
      procedure Write_One (Data : out Unit_Block) is
      begin -- I don't see why Unit'Mod is necessary, but the compiler complained in the bit's case.
         Data(Unit_Block_Range(1 + (Unit_Length mod Final))) := Unit'Mod(2**(Bits - 1));
      end Write_One;
      -- Writing the necessary zeroes is easy in any case, but I think it's better to facter it out.
      -- Unfortunately, the ultimate two words will be unnecessarily modified in some circumstances.
      -- It's important to note this procedure only properly clears that final block used correctly.
      procedure Write_Zeroes (Data : out Unit_Block) is
      begin
         Data(Unit_Block_Range(2 + (Unit_Length mod Final)) .. Data'Last) := (others => 0);
      end Write_Zeroes;
      Remains : constant Natural := Unit_Length mod Final; -- Indexing starting from one simplifies.
   begin
      if Unit_Length = 0 then -- This edge case will best the other cases, requiring explicit check.
         Overflow := False; Write_One(Primary); Write_Zeroes(Primary); -- No other length is needed.
      else -- The first case is Primary entirely used; the second has room; and last lacks overflow.
         Overflow := True; Auxiliary := (others => 0); -- Doing unconditionally simplifies somewhat.
         if Remains = 0 then
            Write_One(Auxiliary); Write_Length(Auxiliary);
         elsif Remains in Final - (Final / 8) .. Final - 1 then
            Write_One(Primary); Write_Zeroes(Primary); Write_Length(Auxiliary);
         else -- This need not be explicit; this denotes that primary has room for all padding bits.
            Write_One(Primary); Write_Zeroes(Primary); Write_Length(Primary); Overflow := False;
         end if;
      end if;
   end Generic_Pad;

   -- How poor in my mind, that these subtypes solely for these instantiations seem to be necessary.
   subtype   Bit_Block_Range is Positive range 1 .. 512;
   subtype Octet_Block_Range is Positive range 1 ..  64;
   subtype  Word_Block_Range is Positive range 1 ..  16;

   -- Unfortunately, I don't seem to be able to simply name these Pad.  I abbreviates Instantiation.
   procedure I_Pad is new Generic_Pad(  Bit,  1,   Bit_Block_Range,   Bit_Block);
   procedure I_Pad is new Generic_Pad(Octet,  8, Octet_Block_Range, Octet_Block);
   procedure I_Pad is new Generic_Pad( Word, 32,  Word_Block_Range,  Word_Block);

   -- How poor again, that these renamings seem to be necessary.  It would be nice, to ellide these.
   -- As a nicety, however, this means there's no additional cost to making the length names unique.
   procedure Pad (Primary      : in out Bit_Block;
                  Auxiliary    :    out Bit_Block;
                  Bit_Length   : in     Natural;
                  Overflow     :    out Boolean) renames I_Pad;
   procedure Pad (Primary      : in out Octet_Block;
                  Auxiliary    :    out Octet_Block;
                  Octet_Length : in     Natural;
                  Overflow     :    out Boolean) renames I_Pad;
   procedure Pad (Primary      : in out Word_Block;
                  Auxiliary    :    out Word_Block;
                  Word_Length  : in     Natural;
                  Overflow     :    out Boolean) renames I_Pad;

   generic
      type Unit is mod <>;
      type Unit_Block_Range is range <>;
      type Unit_Block is array (Unit_Block_Range) of Unit;
      type Unit_Array is array (Positive range <>) of Unit;
      with procedure Hash (State : in out Status; Data : in Unit_Block) is <>;
      with procedure Pad  (Primary     : in out Unit_Block;
                           Auxiliary   :    out Unit_Block;
                           Unit_Length : in     Natural;
                           Overflow    :    out Boolean) is <>;
   function Generic_Hash (Data : in Unit_Array) return Digest;

   function Generic_Hash (Data : in Unit_Array) return Digest is
      State  : Status := Initial_Status;
      Needed : Boolean;
      First, Second : Unit_Block; -- I optimize by using Data slices; these are needed only for Pad.
   begin
      declare
         Position : Positive := Data'First;
      begin
         while Data'Last - Positive(Unit_Block'Last) >= Position loop -- This check avoids overflow.
           Hash(State, Unit_Block(Data(Position .. Position - 1 + Positive(Unit_Block'Last))));
           Position := Position + Positive(Unit_Block'Last);
         end loop;
         for I in Positive range Position .. Data'Last loop -- Unfortunately this isn't declarative.
           First(Unit_Block_Range(1 + I - Position)) := Data(I);
         end loop;
      end;
      Pad(Primary => First, Auxiliary => Second, Unit_Length => Data'Length, Overflow => Needed);
      Hash(State, First);
      if Needed then Hash(State, Second); end if;
      return To_Digest(State);
   end Generic_Hash;

   function I_Hash is new Generic_Hash(  Bit,   Bit_Block_Range,   Bit_Block,   Bit_Array);
   function I_Hash is new Generic_Hash(Octet, Octet_Block_Range, Octet_Block, Octet_Array);
   function I_Hash is new Generic_Hash( Word,  Word_Block_Range,  Word_Block,  Word_Array);

   function Hash (Data : in   Bit_Array) return Digest renames I_Hash;
   function Hash (Data : in Octet_Array) return Digest renames I_Hash;
   function Hash (Data : in  Word_Array) return Digest renames I_Hash;

   -- Defining these function variants is simple enough that a generic form seems reasonable enough.
   generic
      type Unit is mod <>;
      type Unit_Block_Range is range <>;
      type Unit_Block is array (Unit_Block_Range) of Unit;
      with procedure Hash (State : in out Status; Data : in Unit_Block) is <>;
   function Generic_Hash_Function (State : in Status; Data : in Unit_Block) return Status;

   function Generic_Hash_Function (State : in Status; Data : in Unit_Block) return Status is
      Intermediate : Status := State;
   begin
      Hash(Intermediate, Data); return Intermediate;
   end Generic_Hash_Function;

   function I_Hash is new Generic_Hash_Function(  Bit,   Bit_Block_Range,   Bit_Block);
   function I_Hash is new Generic_Hash_Function(Octet, Octet_Block_Range, Octet_Block);
   function I_Hash is new Generic_Hash_Function( Word,  Word_Block_Range,  Word_Block);

   function  Hash (State : in     Status; Data : in   Bit_Block) return Status renames I_Hash;
   function  Hash (State : in     Status; Data : in Octet_Block) return Status renames I_Hash;
   function  Hash (State : in     Status; Data : in  Word_Block) return Status renames I_Hash;

   function To_Digest (State : Status) return Digest is -- I won't bother with an inline pragma now.
   begin
      return Digest(State);
   end To_Digest;

   procedure Bits_To_Words (From : in Bit_Block; To : out Word_Block) is
      Octets : Octet_Block;
      N : Octet := 0;
   begin
      for O in Octet_Block'Range loop
         for B in Positive range (O * 8) - 7 .. (O * 8) loop
            N := (2 * N) + Octet(From(B));
         end loop;
         Octets(O) := N; N := 0;
      end loop;
      Octets_To_Words(Octets, To);
   end Bits_To_Words;

   procedure Octets_To_Words (From : in Octet_Block; To : out Word_Block) is
   begin
      for W in Word_Block'Range loop
         To(W) := (Word(From(W * 4 - 3)) * 2**24) + (Word(From(W * 4 - 2)) * 2**16) +
                  (Word(From(W * 4 - 1)) * 2**8)  +  Word(From(W * 4));
      end loop;
   end Octets_To_Words;

   -- These To_Type functions depend on the array subtype indices starting from one in calculations.
   -- The To_Nibbles function and types exist solely to enable writing To_String and To_Bits easily.
   -- The approach taken with these functions is to exhaustively list, using intermediates for ease.

   type Nibble is mod 2**4;
   type Nibble_Array is array (Positive range <>) of Nibble;

   function To_Nibbles (Datum : in Digest) return Nibble_Array is
      Nibbles : Nibble_Array (1 .. 64);
      Octets  : constant Octet_Array := To_Octets(Datum);
   begin
      for O in Octets'Range loop
         Nibbles(O * 2 - 1) := Nibble'Mod(Octets(O) / 2**4); -- I won't even try to use Shift_Right.
         Nibbles(O * 2)     := Nibble'Mod(Octets(O));
      end loop;
      return Nibbles;
   end To_Nibbles;

   function To_String (Datum : in Digest) return String is
      Characters  : String (1 .. 64);
      Hexadecimal : array (Nibble) of Character := "0123456789ABCDEF"; -- I so wanted to avoid this.
      Nibbles     : constant Nibble_Array := To_Nibbles(Datum);
   begin
      for N in Nibbles'Range loop
         Characters(N) := Hexadecimal(Nibbles(N));
      end loop;
      return Characters;
   end To_String;

   function To_Bits (Datum : in Digest) return Bit_Array is
      Bits    : Bit_Array (1 .. 256);
      Nibbles : constant Nibble_Array := To_Nibbles(Datum);
   begin
      for N in Nibbles'Range loop
         Bits(N * 4 - 3) := Bit'Mod(Nibbles(N) / 2**3);
         Bits(N * 4 - 2) := Bit'Mod(Nibbles(N) / 2**2);
         Bits(N * 4 - 1) := Bit'Mod(Nibbles(N) / 2);
         Bits(N * 4)     := Bit'Mod(Nibbles(N));
      end loop;
      return Bits;
   end To_Bits;

   function To_Octets (Datum : in Digest) return Octet_Array is
      Octets : Octet_Array (1 .. 32);
      Words  : constant Word_Array := To_Words(Datum);
   begin
      for W in Words'Range loop -- I wonder if shifting in the reverse order here is more efficient.
         Octets(W * 4 - 3) := Octet'Mod(Shift_Right(Words(W), 24));
         Octets(W * 4 - 2) := Octet'Mod(Shift_Right(Words(W), 16));
         Octets(W * 4 - 1) := Octet'Mod(Shift_Right(Words(W),  8));
         Octets(W * 4)     := Octet'Mod(            Words(W)     );
      end loop;
      return Octets;
   end To_Octets;

   function To_Words (Datum : in Digest) return Word_Array is
      Words : Word_Array (1 .. 8) := Word_Array(Datum);
   begin
      return Words;
   end To_Words;
end SHA256;
.