------------------------------------------------------------------------------
--                                                                          --
--                         GNAT LIBRARY COMPONENTS                          --
--                                                                          --
--                             G N A T . M D 5                              --
--                                                                          --
--                                B o d y                                   --
--                                                                          --
--                     Copyright (C) 2002-2008, 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.      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Conversion;

package body GNAT.MD5 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).

   --  The sixteen values used to rotate the context words.
   --  Four for each rounds. Used in procedure Transform.

   --  Round 1

   S11 : constant := 7;
   S12 : constant := 12;
   S13 : constant := 17;
   S14 : constant := 22;

   --  Round 2

   S21 : constant := 5;
   S22 : constant := 9;
   S23 : constant := 14;
   S24 : constant := 20;

   --  Round 3

   S31 : constant := 4;
   S32 : constant := 11;
   S33 : constant := 16;
   S34 : constant := 23;

   --  Round 4

   S41 : constant := 6;
   S42 : constant := 10;
   S43 : constant := 15;
   S44 : constant := 21;

   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 (F, FF, G, GG, H, HH, I and II) are the
   --  equivalent of the macros of the same name in the example
   --  C implementation in the annex of RFC 1321.

   function F (X, Y, Z : Unsigned_32) return Unsigned_32;
   pragma Inline (F);

   procedure FF
     (A       : in out Unsigned_32;
      B, C, D : Unsigned_32;
      X       : Unsigned_32;
      AC      : Unsigned_32;
      S       : Positive);
   pragma Inline (FF);

   function G (X, Y, Z : Unsigned_32) return Unsigned_32;
   pragma Inline (G);

   procedure GG
     (A       : in out Unsigned_32;
      B, C, D : Unsigned_32;
      X       : Unsigned_32;
      AC      : Unsigned_32;
      S       : Positive);
   pragma Inline (GG);

   function H (X, Y, Z : Unsigned_32) return Unsigned_32;
   pragma Inline (H);

   procedure HH
     (A       : in out Unsigned_32;
      B, C, D : Unsigned_32;
      X       : Unsigned_32;
      AC      : Unsigned_32;
      S       : Positive);
   pragma Inline (HH);

   function I (X, Y, Z : Unsigned_32) return Unsigned_32;
   pragma Inline (I);

   procedure II
     (A       : in out Unsigned_32;
      B, C, D : Unsigned_32;
      X       : Unsigned_32;
      AC      : Unsigned_32;
      S       : Positive);
   pragma Inline (II);

   procedure Transform
     (C     : 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))) +
           Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 1))), 8) +
           Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 2))), 16) +
           Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 3))), 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 four words (A, B, C, D) of the
      --  Context in Result. Increments Cur.

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

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

   --  Start of processing for Digest

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

      Last_Block (1 .. C.Last) := C.Buffer (1 .. C.Last);

      --  Too many magic literals below, should be defined as constants ???

      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 := 57;

      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.A);
      Convert (C1.B);
      Convert (C1.C);
      Convert (C1.D);
      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;

   -------
   -- F --
   -------

   function F (X, Y, Z : Unsigned_32) return Unsigned_32 is
   begin
      return (X and Y) or ((not X) and Z);
   end F;

   --------
   -- FF --
   --------

   procedure FF
     (A       : in out Unsigned_32;
      B, C, D : Unsigned_32;
      X       : Unsigned_32;
      AC      : Unsigned_32;
      S       : Positive)
   is
   begin
      A := A + F (B, C, D) + X + AC;
      A := Rotate_Left (A, S);
      A := A + B;
   end FF;

   -------
   -- G --
   -------

   function G (X, Y, Z : Unsigned_32) return Unsigned_32 is
   begin
      return (X and Z) or (Y and (not Z));
   end G;

   --------
   -- GG --
   --------

   procedure GG
     (A       : in out Unsigned_32;
      B, C, D : Unsigned_32;
      X       : Unsigned_32;
      AC      : Unsigned_32;
      S       : Positive)
   is
   begin
      A := A + G (B, C, D) + X + AC;
      A := Rotate_Left (A, S);
      A := A + B;
   end GG;

   -------
   -- H --
   -------

   function H (X, Y, Z : Unsigned_32) return Unsigned_32 is
   begin
      return X xor Y xor Z;
   end H;

   --------
   -- HH --
   --------

   procedure HH
     (A       : in out Unsigned_32;
      B, C, D : Unsigned_32;
      X       : Unsigned_32;
      AC      : Unsigned_32;
      S       : Positive)
   is
   begin
      A := A + H (B, C, D) + X + AC;
      A := Rotate_Left (A, S);
      A := A + B;
   end HH;

   -------
   -- I --
   -------

   function I (X, Y, Z : Unsigned_32) return Unsigned_32 is
   begin
      return Y xor (X or (not Z));
   end I;

   --------
   -- II --
   --------

   procedure II
     (A       : in out Unsigned_32;
      B, C, D : Unsigned_32;
      X       : Unsigned_32;
      AC      : Unsigned_32;
      S       : Positive)
   is
   begin
      A := A + I (B, C, D) + X + AC;
      A := Rotate_Left (A, S);
      A := A + B;
   end II;

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

   procedure Transform
     (C     : in out Context;
      Block : String)
   is
      X : Sixteen_Words;

      AA : Unsigned_32 := C.A;
      BB : Unsigned_32 := C.B;
      CC : Unsigned_32 := C.C;
      DD : Unsigned_32 := C.D;

   begin
      pragma Assert (Block'Length = 64);

      Decode (Block, X);

      --  Round 1

      FF (AA, BB, CC, DD, X (00), 16#D76aa478#, S11); --  1
      FF (DD, AA, BB, CC, X (01), 16#E8c7b756#, S12); --  2
      FF (CC, DD, AA, BB, X (02), 16#242070db#, S13); --  3
      FF (BB, CC, DD, AA, X (03), 16#C1bdceee#, S14); --  4

      FF (AA, BB, CC, DD, X (04), 16#f57c0faf#, S11); --  5
      FF (DD, AA, BB, CC, X (05), 16#4787c62a#, S12); --  6
      FF (CC, DD, AA, BB, X (06), 16#a8304613#, S13); --  7
      FF (BB, CC, DD, AA, X (07), 16#fd469501#, S14); --  8

      FF (AA, BB, CC, DD, X (08), 16#698098d8#, S11); --  9
      FF (DD, AA, BB, CC, X (09), 16#8b44f7af#, S12); --  10
      FF (CC, DD, AA, BB, X (10), 16#ffff5bb1#, S13); --  11
      FF (BB, CC, DD, AA, X (11), 16#895cd7be#, S14); --  12

      FF (AA, BB, CC, DD, X (12), 16#6b901122#, S11); --  13
      FF (DD, AA, BB, CC, X (13), 16#fd987193#, S12); --  14
      FF (CC, DD, AA, BB, X (14), 16#a679438e#, S13); --  15
      FF (BB, CC, DD, AA, X (15), 16#49b40821#, S14); --  16

      --  Round 2

      GG (AA, BB, CC, DD, X (01), 16#f61e2562#, S21); --  17
      GG (DD, AA, BB, CC, X (06), 16#c040b340#, S22); --  18
      GG (CC, DD, AA, BB, X (11), 16#265e5a51#, S23); --  19
      GG (BB, CC, DD, AA, X (00), 16#e9b6c7aa#, S24); --  20

      GG (AA, BB, CC, DD, X (05), 16#d62f105d#, S21); --  21
      GG (DD, AA, BB, CC, X (10), 16#02441453#, S22); --  22
      GG (CC, DD, AA, BB, X (15), 16#d8a1e681#, S23); --  23
      GG (BB, CC, DD, AA, X (04), 16#e7d3fbc8#, S24); --  24

      GG (AA, BB, CC, DD, X (09), 16#21e1cde6#, S21); --  25
      GG (DD, AA, BB, CC, X (14), 16#c33707d6#, S22); --  26
      GG (CC, DD, AA, BB, X (03), 16#f4d50d87#, S23); --  27
      GG (BB, CC, DD, AA, X (08), 16#455a14ed#, S24); --  28

      GG (AA, BB, CC, DD, X (13), 16#a9e3e905#, S21); --  29
      GG (DD, AA, BB, CC, X (02), 16#fcefa3f8#, S22); --  30
      GG (CC, DD, AA, BB, X (07), 16#676f02d9#, S23); --  31
      GG (BB, CC, DD, AA, X (12), 16#8d2a4c8a#, S24); --  32

      --  Round 3

      HH (AA, BB, CC, DD, X (05), 16#fffa3942#, S31); --  33
      HH (DD, AA, BB, CC, X (08), 16#8771f681#, S32); --  34
      HH (CC, DD, AA, BB, X (11), 16#6d9d6122#, S33); --  35
      HH (BB, CC, DD, AA, X (14), 16#fde5380c#, S34); --  36

      HH (AA, BB, CC, DD, X (01), 16#a4beea44#, S31); --  37
      HH (DD, AA, BB, CC, X (04), 16#4bdecfa9#, S32); --  38
      HH (CC, DD, AA, BB, X (07), 16#f6bb4b60#, S33); --  39
      HH (BB, CC, DD, AA, X (10), 16#bebfbc70#, S34); --  40

      HH (AA, BB, CC, DD, X (13), 16#289b7ec6#, S31); --  41
      HH (DD, AA, BB, CC, X (00), 16#eaa127fa#, S32); --  42
      HH (CC, DD, AA, BB, X (03), 16#d4ef3085#, S33); --  43
      HH (BB, CC, DD, AA, X (06), 16#04881d05#, S34); --  44

      HH (AA, BB, CC, DD, X (09), 16#d9d4d039#, S31); --  45
      HH (DD, AA, BB, CC, X (12), 16#e6db99e5#, S32); --  46
      HH (CC, DD, AA, BB, X (15), 16#1fa27cf8#, S33); --  47
      HH (BB, CC, DD, AA, X (02), 16#c4ac5665#, S34); --  48

      --  Round 4

      II (AA, BB, CC, DD, X (00), 16#f4292244#, S41); --  49
      II (DD, AA, BB, CC, X (07), 16#432aff97#, S42); --  50
      II (CC, DD, AA, BB, X (14), 16#ab9423a7#, S43); --  51
      II (BB, CC, DD, AA, X (05), 16#fc93a039#, S44); --  52

      II (AA, BB, CC, DD, X (12), 16#655b59c3#, S41); --  53
      II (DD, AA, BB, CC, X (03), 16#8f0ccc92#, S42); --  54
      II (CC, DD, AA, BB, X (10), 16#ffeff47d#, S43); --  55
      II (BB, CC, DD, AA, X (01), 16#85845dd1#, S44); --  56

      II (AA, BB, CC, DD, X (08), 16#6fa87e4f#, S41); --  57
      II (DD, AA, BB, CC, X (15), 16#fe2ce6e0#, S42); --  58
      II (CC, DD, AA, BB, X (06), 16#a3014314#, S43); --  59
      II (BB, CC, DD, AA, X (13), 16#4e0811a1#, S44); --  60

      II (AA, BB, CC, DD, X (04), 16#f7537e82#, S41); --  61
      II (DD, AA, BB, CC, X (11), 16#bd3af235#, S42); --  62
      II (CC, DD, AA, BB, X (02), 16#2ad7d2bb#, S43); --  63
      II (BB, CC, DD, AA, X (09), 16#eb86d391#, S44); --  64

      C.A := C.A + AA;
      C.B := C.B + BB;
      C.C := C.C + CC;
      C.D := C.D + DD;

   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.MD5;