path: root/gcc/ada/g-sha1.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT LIBRARY COMPONENTS                          --
--                                                                          --
--                           G N A T . S H A 1                              --
--                                                                          --
--                                B o d y                                   --
--                                                                          --
--                     Copyright (C) 2002-2006, AdaCore                     --
--                                                                          --
-- 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 2,  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.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  Note: the code for this unit is derived from GNAT.MD5

with Ada.Unchecked_Conversion;

package body GNAT.SHA1 is

   use Interfaces;

   Padding : constant String :=
     (1 => Character'Val (16#80#), 2 .. 64 => ASCII.NUL);

   Hex_Digit : constant array (Unsigned_32 range 0 .. 15) of Character :=
     ('0', '1', '2', '3', '4', '5', '6', '7',
      '8', '9', 'a', 'b', 'c', 'd', 'e', 'f');
   --  Look-up table for each hex digit of the Message-Digest.
   --  Used by function Digest (Context).

   type Sixteen_Words is array (Natural range 0 .. 15)
     of Interfaces.Unsigned_32;
   --  Sixteen 32-bit words, converted from block of 64 characters.
   --  Used in procedure Decode and Transform.

   procedure Decode (Block : String; X : out Sixteen_Words);
   --  Convert a String of 64 characters into 16 32-bit numbers

   --  The following functions are the four elementary components of each
   --  of the four round groups (0 .. 19, 20 .. 39, 40 .. 59, and 60 .. 79)
   --  defined in RFC 3174.

   function F0 (B, C, D : Unsigned_32) return Unsigned_32;
   pragma Inline (F0);

   function F1 (B, C, D : Unsigned_32) return Unsigned_32;
   pragma Inline (F1);

   function F2 (B, C, D : Unsigned_32) return Unsigned_32;
   pragma Inline (F2);

   function F3 (B, C, D : Unsigned_32) return Unsigned_32;
   pragma Inline (F3);

   procedure Transform (Ctx : in out Context; Block : String);
   --  Process one block of 64 characters

   ------------
   -- Decode --
   ------------

   procedure Decode (Block : String; X : out Sixteen_Words) is
      Cur : Positive := Block'First;

   begin
      pragma Assert (Block'Length = 64);

      for Index in X'Range loop
         X (Index) :=
           Unsigned_32 (Character'Pos (Block (Cur + 3))) +
           Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 2))), 8) +
           Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 1))), 16) +
           Shift_Left (Unsigned_32 (Character'Pos (Block (Cur))), 24);
         Cur := Cur + 4;
      end loop;
   end Decode;

   ------------
   -- Digest --
   ------------

   function Digest (C : Context) return Message_Digest is
      Result : Message_Digest;

      Cur : Natural := 1;
      --  Index in Result where the next character will be placed

      Last_Block : String (1 .. 64);

      C1 : Context := C;

      procedure Convert (X : Unsigned_32);
      --  Put the contribution of one of the five H words of the Context in
      --  Result. Increments Cur.

      -------------
      -- Convert --
      -------------

      procedure Convert (X : Unsigned_32) is
         Y : Unsigned_32 := X;
      begin
         for J in 1 .. 8 loop
            Y := Rotate_Left (Y, 4);
            Result (Cur) := Hex_Digit (Y and Unsigned_32'(16#0F#));
            Cur := Cur + 1;
         end loop;
      end Convert;

   --  Start of processing for Digest

   begin
      --  Process characters in the context buffer, if any

      pragma Assert (C.Last /= C.Buffer'Last);
      Last_Block (1 .. C.Last) := C.Buffer (1 .. C.Last);

      if C.Last > 55 then
         Last_Block (C.Last + 1 .. 64) := Padding (1 .. 64 - C.Last);
         Transform (C1, Last_Block);
         Last_Block := (others => ASCII.NUL);

      else
         Last_Block (C.Last + 1 .. 56) := Padding (1 .. 56 - C.Last);
      end if;

      --  Add the input length (as stored in the context) as 8 characters

      Last_Block (57 .. 64) := (others => ASCII.NUL);

      declare
         L   : Unsigned_64 := Unsigned_64 (C.Length) * 8;
         Idx : Positive := 64;
      begin
         while L > 0 loop
            Last_Block (Idx) := Character'Val (L and 16#Ff#);
            L := Shift_Right (L, 8);
            Idx := Idx - 1;
         end loop;
      end;

      Transform (C1, Last_Block);

      Convert (C1.H (0));
      Convert (C1.H (1));
      Convert (C1.H (2));
      Convert (C1.H (3));
      Convert (C1.H (4));
      return Result;
   end Digest;

   function Digest (S : String) return Message_Digest is
      C : Context;
   begin
      Update (C, S);
      return Digest (C);
   end Digest;

   function Digest
     (A : Ada.Streams.Stream_Element_Array) return Message_Digest
   is
      C : Context;
   begin
      Update (C, A);
      return Digest (C);
   end Digest;

   --------
   -- F0 --
   --------

   function F0
     (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32
   is
   begin
      return (B and C) or ((not B) and D);
   end F0;

   --------
   -- F1 --
   --------

   function F1
     (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32
   is
   begin
      return B xor C xor D;
   end F1;

   --------
   -- F2 --
   --------

   function F2
     (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32
   is
   begin
      return (B and C) or (B and D) or (C and D);
   end F2;

   --------
   -- F3 --
   --------

   function F3
     (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32
     renames F1;

   ---------------
   -- Transform --
   ---------------

   procedure Transform
     (Ctx   : in out Context;
      Block : String)
   is
      W : array (0 .. 79) of Interfaces.Unsigned_32;

      A, B, C, D, E, Temp : Interfaces.Unsigned_32;

   begin
      pragma Assert (Block'Length = 64);

      --  a. Divide data block into sixteen words

      Decode (Block, Sixteen_Words (W (0 .. 15)));

      --  b. Prepare working block of 80 words

      for T in 16 .. 79 loop

         --  W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16))

         W (T) := Rotate_Left
           (W (T - 3) xor W (T - 8) xor W (T - 14) xor W (T - 16), 1);

      end loop;

      --  c. Set up transformation variables

      A := Ctx.H (0);
      B := Ctx.H (1);
      C := Ctx.H (2);
      D := Ctx.H (3);
      E := Ctx.H (4);

      --  d. For each of the 80 rounds, compute:

      --  TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t);
      --  E = D;  D = C;  C = S^30(B);  B = A; A = TEMP;

      for T in 0 .. 19 loop
         Temp := Rotate_Left (A, 5) + F0 (B, C, D) + E + W (T) + 16#5A827999#;
         E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp;
      end loop;

      for T in 20 .. 39 loop
         Temp := Rotate_Left (A, 5) + F1 (B, C, D) + E + W (T) + 16#6ED9EBA1#;
         E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp;
      end loop;

      for T in 40 .. 59 loop
         Temp := Rotate_Left (A, 5) + F2 (B, C, D) + E + W (T) + 16#8F1BBCDC#;
         E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp;
      end loop;

      for T in 60 .. 79 loop
         Temp := Rotate_Left (A, 5) + F3 (B, C, D) + E + W (T) + 16#CA62C1D6#;
         E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp;
      end loop;

      --  e. Update context:
      --  H0 = H0 + A, H1 = H1 + B, H2 = H2 + C, H3 = H3 + D, H4 = H4 + E

      Ctx.H (0) := Ctx.H (0) + A;
      Ctx.H (1) := Ctx.H (1) + B;
      Ctx.H (2) := Ctx.H (2) + C;
      Ctx.H (3) := Ctx.H (3) + D;
      Ctx.H (4) := Ctx.H (4) + E;
   end Transform;

   ------------
   -- Update --
   ------------

   procedure Update
     (C     : in out Context;
      Input : String)
   is
      Inp : constant String := C.Buffer (1 .. C.Last) & Input;
      Cur : Positive := Inp'First;

   begin
      C.Length := C.Length + Input'Length;

      while Cur + 63 <= Inp'Last loop
         Transform (C, Inp (Cur .. Cur + 63));
         Cur := Cur + 64;
      end loop;

      C.Last := Inp'Last - Cur + 1;
      C.Buffer (1 .. C.Last) := Inp (Cur .. Inp'Last);
   end Update;

   procedure Update
     (C     : in out Context;
      Input : Ada.Streams.Stream_Element_Array)
   is
      subtype Stream_Array is Ada.Streams.Stream_Element_Array (Input'Range);
      subtype Stream_String is
        String (1 + Integer (Input'First) .. 1 + Integer (Input'Last));

      function To_String is new Ada.Unchecked_Conversion
        (Stream_Array, Stream_String);

      String_Input : constant String := To_String (Input);
   begin
      Update (C, String_Input);
   end 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;

   -----------------
   -- Wide_Update --
   -----------------

   procedure Wide_Update
     (C     : in out Context;
      Input : Wide_String)
   is
      String_Input : String (1 .. 2 * Input'Length);
      Cur          : Positive := 1;

   begin
      for Index in Input'Range loop
         String_Input (Cur) :=
           Character'Val
            (Unsigned_32 (Wide_Character'Pos (Input (Index))) and 16#FF#);
         Cur := Cur + 1;
         String_Input (Cur) :=
           Character'Val
           (Shift_Right (Unsigned_32 (Wide_Character'Pos (Input (Index))), 8)
            and 16#FF#);
         Cur := Cur + 1;
      end loop;

      Update (C, String_Input);
   end Wide_Update;

end GNAT.SHA1;